(declare (leng colleft plen pvec) special)
(declare (leng colleft plen) fix-value)
(defun prind (x (leng (linelength)) (asblock) (plev) (plen) (pvec t))
   (and plev (setq x (*prune x plev (cond (plen (/1- plen)) (t 999999)))))
   (and usebq (not plev) (setq x (eliminate-comma (usebq x))))
   (*prind x (cursor) 0 asblock)
   (terpri))
(putd 'grind (getd 'prind))
(defun *prune (x plev pl)
   (cond ((atom x) x)
         ((/0= plev) '?)
         ((and (/0= pl) (cdr x)) '(???))
         (t `(,(*prune (car x) (/1- plev) plen) . 
              ,(*prune (cdr x) plev (/1- pl))))))
(defun *prind (x indent close (asblock))
   (tab indent)
   (cond ((*simpleatom x) (prin1 x))
         ((vectorp x) (princ "#") (*prind (*vec2list x) (/1+ indent) close t))
         ((or (printable x (min (/- leng (cursor) close) 80))
              (and (*simpleatom (car x)) (*simpleatom (cdr x))))
          (*prin1 x))
         ((and (memq (car x) '(quote bq comma function))
               (consp (cdr x))
               (null (cddr x)))
          (*quote x indent close))
         ((eq (car x) 'dotted) (*dotted x indent close))
         (t (princ "(")
            (funcall (cond ((or asblock (< (/- leng (cursor) close) 40))
                            #'*block)
                           ((symbolp (car x))
                            (or (and (every (cdr x) #'*simpleatom) #'*block)
                                (get (car x) 'prind)
                                #'*standard))
                           ((or (*simpleatom (car x))
                                (and (consp (car x))
                                     (cdar x)
                                     (*simpleatom (cdar x))))
                            #'*block)
                           (t #'*miser))
               x
               (/1+ indent)
               (/1+ close))
            (princ ")"))))
(defun *standard (x indent close)
   (prin1 (car x))
   (*miser (cdr x)
           (lets ((n (atomlength (car x))))
            (/+ indent 1 (cond ((> n 6) 1) (t n))))
           close))
(defun *quote (x indent close)
   (cond ((eq (car x) 'function)
          (princ "#'")
          (*prind (cadr x) (/+ indent 2) close))
         (t (princ (cdr (assq (car x)
                           '((quote . "'") (bq . "`") (comma . ",")))))
            (*prind (cadr x) (/1+ indent) close))))
(defun *dotted (x indent close)
   (princ "(")
   (loop (*prind (car (second x)) (/1+ indent) close)
         (or (and (consp (second (second x)))
                  (eq (car (second (second x))) 'dotted))
             (exit))
         (princ " ")
         (setq x (second (second x))))
   (and (not (null (second (second x))))
        (progn (cond ((> (/- leng (cursor)) 3) (princ " . ") (tab (/1+ indent)))
                     (t (tab indent) (princ " . ")))
               (*prind (second (second x)) (cursor) (/1+ close))))
   (princ ")"))
(defun *miser (x indent close)
   (do nil ((atom x)) (*prind (pop x) indent (cond ((null x) close) (t 0))))
   (or (null x)
       (progn (tab indent)
              (princ ". ")
              (*prind x (cursor) close (not (*simpleatom x))))))
(defun *setq (x indent close)
   (prin1 (pop x))
   (setq indent (/1+ (cursor)))
   (do nil
       ((or (atom x) (not (symbolp (car x))) (atom (cdr x))))
       (*prind (pop x) indent 0)
       (princ " ")
       (*prind (pop x) (cursor) (cond ((null x) close) (t 0))))
   (*miser x indent close))
(defun *defun (x indent close)
   (cond ((consp (second x)) (*block x indent close))
         (t (prin1 (pop x)) (princ " ") (*withvars x indent close))))
(defun *withvars (x indent close)
   (prin1 (pop x))
   (princ " ")
   (*prind (pop x) (cursor) 0 t)
   (*miser x (/+ indent 2) close))
(defun *lambda (x indent close)
   (prin1 (pop x))
   (princ " ")
   (*prind (pop x) (cursor) 0 t)
   (*miser x indent close))
(defun *function (x indent close) (prin1 (pop x)) (*miser x indent close))
(defun *funcall (x indent close)
   (prin1 (pop x))
   (princ " ")
   (*prind (pop x) (cursor) 0)
   (*miser x (/+ indent 2) close))
(defun *prog (x indent close)
   (prin1 (pop x))
   (princ " ")
   (*prind (pop x) (cursor) 0 t)
   (setq indent (/+ indent 2))
   (loop (and (atom x) (exit))
         (*prind (car x)
                 (cond ((atom (pop x)) (max 1 (/- indent 10))) (t indent))
                 (cond ((null x) close) (t 0))))
   (or (null x)
       (progn (tab indent)
              (princ ". ")
              (*prind x (cursor) close (not (*simpleatom x))))))
(defun *block (x indent close)
   (do nil
       ((atom x)
        (or (null x)
            (progn (or (< (cursor) indent) (tab indent))
                   (or (printable
                          x
                          (/- (min leng (/+ indent 80)) (cursor) close 2))
                       (tab indent))
                   (princ ". ")
;                   (print "sokosoko")
                   (*prind x (cursor) indent close))))
       (cond ((or (printable
                     (car x)
                     (/-(min leng (/+ indent 80))
                        (cursor)
                        (cond ((null (cdr x)) close) (t 1))))
                  (and (neq (cursor) indent)
                       (progn (tab indent)
                              (printable
                                 (car x)
                                 (/-(min leng (/+ indent 80))
                                    indent
                                    (cond ((null (cdr x)) close) (t 1)))))))
              (*prin1 (pop x))
              (or (atom x) (eq (cursor) leng) (princ " ")))
             (t (*prind (pop x) (cursor) (cond ((null x) close) (t 0)))
                (or (null x) (tab indent))))))
(defun printable (x colleft) (*printable x))
(defun *printable (x)
   (cond ((*simpleatom x) (/0< (decr colleft (atomlength x))))
         ((vectorp x)
          (lets ((i 0) (n (vector-length x)))
           (loop (and (<= n i) (exit (/0< (decr colleft 1))))
                 (or (*printable (prog2 (decr colleft 1) (vref x i))) (exit))
                 (incr i 1))))
         ((and (memq (car x) '(comma bq quote function))
               (consp (cdr x))
               (null (cddr x)))
          (decr colleft (cond ((eq (car x) 'function) 2) (t 1)))
          (*printable (cadr x)))
         ((eq (car x) 'dotted)
          (decr colleft 2)
          (loop (or (*printable (first (second x))) (exit nil))
                (or (and (consp (second (second x)))
                         (eq (car (second (second x))) 'dotted))
                    (exit (cond ((null (second (second x))) (/0< colleft))
                                (t (decr colleft 3)
                                   (*printable (second (second x)))))))
                (setq x (second (second x)))
                (decr colleft 1)))
         (t (loop (cond ((*simpleatom x)
                         (exit (/0<(decr colleft
                                         (cond ((null x) 1) 
                                          (t (/+ (atomlength x) 5)))))))
                        ((vectorp x)
                         (exit (*printable (prog2 (decr colleft 3) x)))))
                  (or (*printable (prog2 (decr colleft 1) (car x))) (exit))
                  (pop x)))))
(defun *prin1 (x)
   (cond ((*simpleatom x) (prin1 x))
         ((vectorp x)
          (princ "#(")
          (lets ((i 0) (n (vector-length x)))
           (loop (cond ((<= n i) (exit)) ((/0< i) (princ " ")))
                 (*prin1 (vref x i))
                 (incr i 1)))
          (princ ")"))
         ((and (memq (car x) '(quote bq comma function))
               (consp (cdr x))
               (null (cddr x)))
          (princ (cdr (assq (car x)
                         '((quote . "'") (bq . "`") (comma . ",") 
                           (function . "#'")))))
          (*prin1 (cadr x)))
         ((eq (car x) 'dotted)
          (princ "(")
          (loop (*prin1 (first (second x)))
                (or (and (consp (second (second x)))
                         (eq (car (second (second x))) 'dotted))
                    (exit))
                (princ " ")
                (setq x (second (second x))))
          (and (not (null (second (second x))))
               (progn (princ " . ") (*prin1 (second (second x)))))
          (princ ")"))
         (t (princ "(")
            (loop (*prin1 (pop x))
                  (cond ((consp x) (princ " "))
                        ((not (null x)) (princ " . ") (*prin1 x) (exit))
                        (t (exit))))
            (princ ")"))))
(defun *simpleatom (x) (and (atom x) (not (and (vectorp x) pvec))))
(defun *vec2list (v)
   (do ((i 0 (1+ i)) (n (vector-length v)) (l))
       ((= i n) (nreverse l))
       (push (vref v i) l)))
(defun usebq (x)
   (cond ((atom x) x)
         ((cdr (last x)) x)
         ((memq (car x) '(bq comma dotted)) `(,(car x) ,(usebq (second x))))
         (t (lets ((y (mapcar x #'usebq)))
             (cond ((and (eq (car y) 'cons)
                         (consp (cdr y))
                         (not (equal (second y) ''list))
                         (consp (cddr y))
                         (null (cdddr y))
                         (or (atom (second y))
                             (neq (car (second y)) 'quote)
                             (atom (third y))
                             (neq (car (third y)) 'quote)))
                    `(bq (dotted ,(usebq (mapcar (cdr y) 
                                          #'(lambda (y) 
                                             (cond ((memq y '(t nil)) y) 
                                              ((symbolp y) `(comma ,y)) 
                                              ((atom y) y) 
                                              ((and (eq (car y) 'quote) 
                                                (consp (cdr y)) 
                                                (null (cddr y)))
                                               (second y))
                                              (t `(comma ,y)))))))))
                   ((and (eq (first y) 'list)
                         (some (cdr y)
                            #'(lambda (y)
                               (or (atom y) (neq (car y) 'quote)))))
                    `(bq ,(usebq (mapcar (cdr y)
                                    #'(lambda (y) 
                                       (cond ((memq y '(t nil)) y) 
                                        ((symbolp y) `(comma ,y)) 
                                        ((atom y) y) 
                                        ((and (eq (car y) 'quote) 
                                          (consp (cdr y)) (atom (cddr y)))
                                         (second y))
                                        (t `(comma ,y))))))))
                   (t y))))))
(defun eliminate-comma (x)
   (cond ((atom x) x)
         ((and (eq (car x) 'comma)
               (consp (second x))
               (eq (car (second x)) 'bq))
          (eliminate-comma (second (second x))))
         (t `(,(eliminate-comma (car x)) . ,(eliminate-comma (cdr x))))))
(mapc '(function) #'(lambda (x) (putprop x #'*function 'prind)))
(mapc '(lambda let lets) #'(lambda (x) (putprop x #'*lambda 'prind)))
(mapc '(defun macro defmacro) #'(lambda (x) (putprop x #'*defun 'prind)))
(mapc '(prog) #'(lambda (x) (putprop x #'*prog 'prind)))
(mapc '(setq) #'(lambda (x) (putprop x #'*setq 'prind)))
(mapc '(selectq match assq assoc delq remq map maplist mapcon mapc mapcar 
        mapcan mapv mapvector some every rplaca rplacd funcall defprop 
        putprop catch throw)
   #'(lambda (x) (putprop x #'*funcall 'prind)))
(remob 'comma)
(remob 'bq)
(remob 'dotted)
