;;; -*- coding:utf-8 -*-
;;;;****************************************************************************
;;;;FILE:               lisp-to-dot.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    This packages generates a GraphViz dot file from a lisp object.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2009-08-17 <PJB> Rewritten to generate dot files.
;;;;    2009-07-18 <PJB> Started rewriting to deal with additionnal cell types
;;;;                     (vectors, structures), and more complex structures
;;;;                     (shared and circular).
;;;;    2005-08-19 <PJB> Added PRINT-CONS and PRINT-IDENTIFIED-CONS.
;;;;    2004-09-24 <PJB> Corrected DRAW-LISP.
;;;;    2004-08-14 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;;    GPL
;;;;
;;;;    Copyright Pascal J. Bourguignon 2004 - 2009
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU General Public License
;;;;    as published by the Free Software Foundation; either version
;;;;    2 of the License, or (at your option) any later version.
;;;;
;;;;    This program is distributed in the hope that it will be
;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;;;    PURPOSE.  See the GNU General Public License for more details.
;;;;
;;;;    You should have received a copy of the GNU General Public
;;;;    License along with this program; if not, write to the Free
;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;;    Boston, MA 02111-1307 USA
;;;;****************************************************************************

(in-package "COMMON-LISP-USER")
(defpackage "COM.INFORMATIMAGO.COMMON-LISP.LISP-TO-DOT"
  (:nicknames "LTD")
  (:use "COMMON-LISP"
        "SPLIT-SEQUENCE"
        "COM.INFORMATIMAGO.COMMON-LISP.STRING" )
  (:export "GENERATE")
  (:documentation
   "This packages draws the lisp objects as GraphViz dot diagrams.

    Copyright Pascal J. Bourguignon 2004 - 2009
    This package is provided under the GNU General Public License.
    See the source file for details."))
(in-package "COM.INFORMATIMAGO.COMMON-LISP.LISP-TO-DOT")


(defgeneric generate (object stream)
  (:documentation "Generate a dot file part for the OBJECT onto the STREAM."))




(defgeneric object-slot (object)
  (:documentation "Return a p-list containing the slots of the object to be printed."))


(defmacro define-print-object (((self class) stream) field-list-expression)
  (let ((fields  (gensym)))
    `(progn
       (defmethod object-slots ((,self ,class))
         (let ((result ,field-list-expression))
           (if (next-method-p)
             (append (call-next-method) result)
             result)))
       (defmethod print-object ((,self ,class) ,stream)
         (if *print-readably*
           (format ,stream "#.~S" `(make-instance ',(class-name (class-of self))
                                     ;; Notice: the actual class of self.
                                     ,@(mapcar (lambda (x) `(quote ,x)) (object-slots ,self))))
           (print-unreadable-object (,self ,stream :type t :identity t)
             (prin1 (object-slots ,self) ,stream)))
         ,self))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; NODE

(defclass node ()
  ((object :accessor node-object :initarg :object :initform nil :type t)
   (id     :reader   node-id     :initform (gensym "N")))
  (:documentation "An abstract graphic node, representing some ATOM or CONS."))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ATOM-NODE

(defclass atom-node (node)
  (;; (lines :documentation "Textual representation of the node.")
   )
  (:documentation "A node representing an atomic atom.
The content of the node will be the string obtained from PRIN1-TO-STRING of the OBJECT.
Displayed as:

       +--------------+
       | prin1-output |
       +--------------+
"))


(defun prepare-label (label)
  (with-output-to-string (output)
    (loop
       :for ch :across label
       :do (princ (case ch
                    ((#\Newline) "\\l")
                    ((#\Space) "\\ ")
                    ((#\") "\\\"")
                    ((#\\) "\\\\")
                    (otherwise ch)) output))))


(defmethod generate ((self atom-node) stream)
  (format stream "~A[shape=\"rectangle\",label=\"~A\"];~%"
          (node-id self)
          (prepare-label (prin1-to-string (node-object self))))
  self)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CONS-NODE

(defclass cons-node (node)
  ((car  :accessor car-node  :initarg :car  :initform nil :type (or null node))
   (cdr  :accessor cdr-node  :initarg :cdr  :initform nil :type (or null node)))
  (:documentation "A node representing a cons cell. Displayed as:

        +---+---+
        | * |NIL|
        +---+---+
          |
          v
         ...

Only NIL will be represented inside the cons cell, all the other atoms will be boxed.
"))


(defmethod generate ((self cons-node) stream)
  (format stream "~A[shape=\"record\",label=\"{<car> ~:[NIL~;~]|<cdr> ~:[NIL~;~]}\"];~%"
          (node-id self)
          (car (node-object self))
          (cdr (node-object self)))
  (when (car (node-object self))
    (format stream "~A:car -> ~A;~%" (node-id self) (node-id (car-node self))))
  (when (cdr (node-object self))
    (format stream "~A:cdr -> ~A;~%" (node-id self) (node-id (cdr-node self))))
  self)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; VECTOR-NODE


(defvar *vector-length* nil
  "When non-nil, must be an integer giving the maximum number of slots
of a vector to display.
If more slots exist, then only those from 0 to (- *vector-length* 2)
and the last are displayed.")


(defclass vector-node (node)
  ((slots :accessor slot-nodes :initarg :slots :initform #() :type (vector node)))
  (:documentation "A node representing a vector. Displayed vectically as:

      @ +---+
      0 | * |--> ...
        +---+
      1 |NIL|
        +---+
      2 | * |--> ...
        +---+
         ...
        +---+
      N | * |--> ...
        +---+

Only NIL will be represented inside the slot, all the other atoms will be boxed.
Notice that if displayed vertically, the boxes of the elements will be shifted down.
*VECTOR-LENGTH* indicates the maximum number of slots of a vector that are displayed.
The first and last slots are always displayed.
"))


(defmethod generate ((self vector-node) stream)
  (format stream "~A[shape=\"record\",label=\"~{<~D> ~:*~D~^|~}\"];~%"
          (node-id self)
          (if (or (null *vector-length*)
                  (<= (length (node-object self)) *vector-length*))
              (loop :for i :below (length (node-object self)) :collect i)
              (nconc (loop :for i :below (- *vector-length* 2) :collect i)
                     (list "..." (1- (length (node-object self)))))))
  (if (or (null *vector-length*)
          (<= (length (node-object self)) *vector-length*))
      (loop
         :for i :below (length (node-object self))
         :do (format stream "~A:~D -> ~A;~%" (node-id self) i (node-id (aref (slot-nodes self) i))))
      (loop
         :for i :below (- *vector-length* 2)
         :do (format stream "~A:~D -> ~A;~%" (node-id self) i (node-id (aref (slot-nodes self) i)))
         :finally
         (let ((i  (1- (length (node-object self)))))
           (format stream "~A:~D -> ~A;~%" (node-id self) i (node-id (aref (slot-nodes self) i))))))
  self)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SLOT-DESCRIPTION

(defclass slot-description ()
  ((name     :accessor slot-name     :initarg :name     :type (or symbol string))
   (reader   :accessor slot-reader   :initarg :reader   :type (or symbol function))
   (writer   :accessor slot-writer   :initarg :writer   :type (or symbol function)))
  (:documentation "Describes a structure slot.
The NAME is a string or symbol naming the slot.
The READER is a function or a symbol naming a function that takes a structure as
argument and returns the value of the described slot.
The WRITER is a function or a symbol naming a function that takes a new value
and a structure as arguments and sets the described slot.  It shall return the new value.
"))

(define-print-object ((self slot-description) stream)
    (list :name (slot-name self)
          :reader (slot-reader self)
          :writer (slot-writer self)))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; STRUCTURE-DESCRIPTION

(defclass structure-description ()
  ((name              :accessor structure-name :initarg :name :type (or symbol string)
                      :documentation "The name of the structure type described.")
   (slot-descriptions :accessor structure-slots :initarg :slots
                      :initform #() :type (vector slot-description)))
  (:documentation "Describe a structure type.
The NAME is a string or symbol naming the structure type.
The SLOT-DESCRIPTIONS is a vector describing the slots of the structure."))

(define-print-object ((self structure-description) stream)
    (list :name (structure-name self) :slot-descriptions (structure-slots self)))

(defmethod slot-count ((self structure-description))
  (length (structure-slots self)))

(defmethod slot-ref ((self structure-description) index)
  (aref (structure-slots self) index))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; STRUCTURE-INSTANCE

(defclass structure-instance ()
  ((structure :reader instance-structure :initarg :structure :type structure-description
              :documentation "The STRUCTURE-DESCRIPTION representing the structure class
of the structure object represented by this STRUCTURE-INSTANCE instance.")
   (slots     :reader instance-slots :initarg :slots :type vector))
  (:documentation "Structure-instance instances represent instances of
structure-class subclasses.  They are used to represent lisp
structures without really creating the structure type, which is not really useful
given the lack of MOP API for structures."))

(define-print-object ((self structure-instance) stream)
    (list :structure (structure-name (instance-structure self))
          :slots (map 'vector
                      (lambda (slot-desc slot-val) (cons (slot-name slot-desc) slot-val))
                      (structure-slots (instance-structure self))
                      (instance-slots self))))

(defmethod slot-count ((self structure-instance))
  (length (instance-slots self)))

(defmethod slot-ref ((self structure-instance) index)
  (aref (instance-slots self) index))


(defun make-structure-instance (slots)
  "Build a structure-instance from the list obtained by reading #S(POINT :X 42 :Y 32)
SLOTS:  a list: (POINT :X 42 :Y 32)
RETURN: a STRUCTURE-INSTANCE ; a STRUCTURE-DESCRIPTION"
  (destructuring-bind (structure-name &rest slots &key &allow-other-keys) slots
    (loop
       :for (k v) :on slots :by (function cddr)
       :collect k :into slot-names
       :collect v :into slot-values
       :finally (let ((sclass
                       (make-instance 'structure-description
                         :name structure-name
                         :slots (map 'vector
                                     (let ((i -1))
                                       (lambda (slot-name)
                                           (incf i)
                                           (make-instance 'slot-description
                                             :name slot-name
                                             :reader (lambda (instance)
                                                         (aref (instance-slots instance) i))
                                             :writer (lambda (new-value instance)
                                                         (setf (aref (instance-slots instance) i)
                                                          new-value)))))
                                     slot-names))))
                  (return (values (make-instance 'structure-instance
                                    :structure sclass
                                    :slots (make-array (length slot-values)
                                                       :initial-contents slot-values))
                                  sclass))))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; STRUCTURE-NODE

(defvar *structure-length* nil
  "When non-nil, must be an integer giving the maximum number of slots
of a structure to display.
If more slots exist, then only those from 0 to (- *structure-length* 2)
and the last are displayed.")


(defclass structure-node (node)
  ((structure    :accessor node-structure
                 :initarg :structure
                 :type     structure-description
                 :documentation "The description of the structure type of which this node represents an instance.")
   (slots        :accessor slot-nodes
                 :initarg :slots
                 :initform #()
                 :type (vector node)))
  (:documentation "A node representing a structure.
Notice that CL implementations don't necessarily provide a MOP for structures,
so the structure descriptions must be given explicitely.
Only the described slots are displayed.  Displayed vectically as:

  structure-name
               +---+
  slot-name-0: | * |--> ...
               +---+
  slot-name-1: |NIL|
               +---+
  slot-name-2: | * |--> ...
               +---+
                ...
               +---+
  slot-name-N: | * |--> ...
               +---+

Only NIL will be represented inside the slot, all the other atoms will be boxed.
Notice that if displayed vertically, the boxes of the elements will be shifted down.
*STRUCTURE-LENGTH* indicates the maximum number of slots of a structure that are displayed.
The first and last slots are always displayed.
"))



(defmethod generate ((self structure-node) stream)
  (format stream "~A[shape=\"record\",label=\"~{<~D> ~:*~A~^|~}\"];~%"
          (node-id self)
          (if (or (null *structure-length*)
                  (<= (length (slot-nodes self)) *structure-length*))
              (loop :for i :below (length (slot-nodes self)) :collect i)
              (nconc (loop :for i :below (- *structure-length* 2) :collect i)
                     (list "..." (1- (length (slot-nodes  self)))))))
  (if (or (null *structure-length*)
          (<= (length (slot-nodes self)) *structure-length*))
      (loop
         :for k :
         :for i :below (length (slot-nodes self))
         :do (format stream "~A:~A -> ~A;~%" (node-id self) i (node-id (aref (slot-nodes self) i))))
      (loop
         :for i :below (- *vector-length* 2)
         :do (format stream "~A:~A -> ~A;~%" (node-id self) i (node-id (aref (slot-nodes self) i)))
         :finally
         (let ((i  (1- (length (node-object self)))))
           (format stream "~A:~A -> ~A;~%" (node-id self) i (node-id (aref (slot-nodes self) i))))))
  self)





#||
(defclass hash-table-node (node)
((entries :accessor entry-nodes :initarg :entries :initform (make-hash-table) :type hash-table)))



(values (make-instance 'node      :object "abc" :x 0 :y 0 :w 7 :h 3)
(make-instance 'atom-node :object "abc" :x 0 :y 0 :w 7 :h 3)
(make-instance 'cons-node :object '(#1="car" . #2="cdr")
:x 0 :y 0 :w 17 :h 3
:car (make-instance 'atom-node :object #1# :x 0 :y 0 :w 7 :h 3)
:cdr (make-instance 'atom-node :object #2# :x 9 :y 0 :w 7 :h 3)))


||#



(defvar *nodes* nil
  "A HASH-TABLE mapping lisp objects to instances of subclasses of NODE.
Used by IDENTIFY-SHARED-OBJECTS.")


(defgeneric identify-shared-objects (object)
  (:documentation "Maps the s-exp OBJECT into NODES, taking care of shared substructures
and circularities."))


(defmethod identify-shared-objects ((self t))
  (multiple-value-bind (o p) (gethash self *nodes*)
    (if p
      (add-reference o)
      (setf (gethash self *nodes*) (make-instance 'atom-node :object self)))))


(defmethod identify-shared-objects ((self cons))
  (multiple-value-bind (o p) (gethash self *nodes*)
    (if p
      (add-reference o)
      (setf (gethash self *nodes*)
            (make-instance 'cons-node
              :object self
              :car (identify-shared-objects (car self))
              :cdr (identify-shared-objects (cdr self)))))))


(defmethod identify-shared-objects ((self vector))
  (multiple-value-bind (o p) (gethash self *nodes*)
    (if p
      (add-reference o)
      (setf (gethash self *nodes*)
            (make-instance 'vector-node
              :object self
              :slots (map 'vector (function identify-shared-objects) self))))))


(defmethod identify-shared-objects ((self string))
  ;; STRING is a subclass of VECTOR
  (multiple-value-bind (o p) (gethash self *nodes*)
    (if p
      (add-reference o)
      (setf (gethash self *nodes*) (make-instance 'atom-node :object self)))))


(defmethod identify-shared-objects ((self structure-instance))
  (multiple-value-bind (o p) (gethash self *nodes*)
    (if p
      (add-reference o)
      (setf (gethash self *nodes*)
            (make-instance 'structure-node
              :object self
              :structure (instance-structure self)
              :slots (map 'vector (function identify-shared-objects)
                          (instance-slots self)))))))






(defun structure-instance-reader-dispatching-macro (stream subchar arg)
  (declare (ignore subchar arg))
  (let ((data (read stream t nil t)))
    (check-type data list)
    (values (make-structure-instance data))))


(defparameter *cta-readtable*
  (let ((rt (copy-readtable nil)))
    (set-dispatch-macro-character #\# #\S (function structure-instance-reader-dispatching-macro) rt)
    rt))

(defun read-sexp (stream)
  (let ((*readtable*                  *cta-readtable*)
        (*read-base*                  10.)
        (*read-default-float-format* 'single-float)
        (*read-eval*                  nil))
    (read stream nil 'end-of-file)))






(defun test/read-sexp ()
  (setf *print-readably* nil *print-circle* t)
  (let* ((*nodes* (make-hash-table))
         (root
          (print
           (identify-shared-objects
            (with-input-from-string (inp "(#1=#S(POINT :X 42 :Y 36)
                                   #2=(a b c)
                                   #(SYM NIL \"BCD\" 42.36 #1#)
                                   #2# SYM #2# SOM #2#)")
              (read-sexp inp)))))
         (objects (make-array (hash-table-count *nodes*))))
    (maphash (let ((i -1)) (lambda (k v) (setf (aref objects (incf i)) v))) *nodes*)
    (setf objects (sort objects (function >) :key (function node-refcount)))))



(defparameter *pict*
  (frame-rect (MAKE-instance 'PICTURE :width 72 :height 30 :background " ")
              0 0 72 30))

(defun clear ()
  (fill-rect  *pict* 0 0 (width *pict*) (height *pict*) :foreground " ")
  (frame-rect *pict* 0 0 (width *pict*) (height *pict*))
  *pict*)

(defun test/draw ()
  (setf *vector-length* 4)
  (setf *structure-length* 4)
  (clear)
  (let* ((text (make-instance 'atom-node :object (format nil "Hello World!~%Bonjour le Monde !")))
         (numb (make-instance 'atom-node :object 42.101010d0))
         (cons (make-instance 'cons-node :object (cons (node-object text)
                                                       (node-object numb))))
         (vect (make-instance 'vector-node :object (vector (node-object text)
                                                           (node-object numb)
                                                           (node-object cons)
                                                           0 0 0 0 0 0 0 0 12 24 36 48)))
         (stru (make-instance 'structure-node :object (make-structure-instance
                                                       (list 'example-structure
                                                             :text (node-object text)
                                                             :number (node-object numb)
                                                              :cons (node-object cons)
                                                             :slot-a 0
                                                             :slot-b 0
                                                             :slot-c 0
                                                             :fourty-two 42)))))
    (setf (node-structure stru) (instance-structure (node-object stru)))
    (compute-node-size text *pict*)
    (compute-node-size numb *pict*)
    (compute-node-size cons *pict*)
    (compute-node-size vect *pict*)
    (compute-node-size stru *pict*)
    (setf (x text) 5
          (y text) 5
          (x cons) 40
          (y cons) 10
          (x numb) 43
          (y numb) 20
          (x vect) 5
          (y vect) 22
          (x stru) 16
          (y stru) 24)
    (draw numb *pict*)
    (draw text *pict*)
    (draw cons *pict*)
    (draw vect *pict*)
    (draw stru *pict*)
    (draw (line (point (1- (x cons))         (1- (y cons)))
                (point 30                    (1- (y cons)))
                (point 30                    (1- (y text)))
                (point (+ (x text) (w text)) (1- (y text)))) *pict*)
    (draw (line (point (+ (x cons) 6)        (1+  (y cons)))
                (point (+ (x numb) 3)        (- (y numb) 3))) *pict*)))

;; (test/read-sexp)
;; (test/draw)


#-(and)
(progn

  (defun draw-named-values (name-and-value-alist)
    (let ((*nodes* (make-hash-table)))

      ))


  (defun draw-values (values)
    (draw-named-values
     (mapcar (let ((i 0))
               (lambda (value) (cons (format nil "~R" (incf i)) value)))
             values)))







  (defgeneric size-cell (pict cell &optional max-width))
  (defgeneric draw-cons (pict x y cell))
  (defgeneric draw-cell (pict x y cell))
  (defgeneric draw-decorated-cell (pict x y dec))

  (defvar +cell-width+ 12 "+---+---+")


  (defmethod size-cell ((pict picture) cell &optional (max-width (width pict)))
    (cond
      ((null cell) (values :absent 0 0))
      ((atom cell) (let ((rep (format nil "~S" cell)))
                     (multiple-value-bind (l b w h) (size-string pict rep)
                       (declare (ignore l b))
                       (values :horizontal (+ w 4) (+ h 2)))))
      (t
       ;; first compute horizontal layout ;
       ;; if too large, then compute a vertical layout (could still be too large). ;
       (let ((width  0)
             (height 0)
             (dispo))
         (when (<= (length cell) (truncate max-width +cell-width+))
           ;; horizontal                  ;
           (setf dispo :horizontal)
           (do  ((items cell (cdr items))
                 (i 0 (1+ i)))
                ((null items))
             (multiple-value-bind (d w h) (size-cell pict (car items))
               (declare (ignore d))
               (setf width  (max width  (+ w (* i +cell-width+))))
               (setf height (max height (+ h 5))))))
         (when (<= (width pict) width)
           ;; vertical                    ;
           ;; (setf dispo :vertical)      ;
           )
         (values dispo width height)))))






  (defvar +picture-instance+ (make-instance 'picture :width 1 :height 1))
  (defvar +nil-decoration+   (make-instance 'atom-decoration))


  (defmethod initialize-instance ((self atom-decoration) &rest args)
    (declare (ignore args))
    (call-next-method)
    (multiple-value-bind (d w h) (size-cell +picture-instance+ (atom-value self))
      (declare (ignore d))
      (setf (w self) w (h self) h))
    self)


  (defun decorate (cell)
    "
DOES:    Converts the list CELL to a decorated list.
         The building of the decoration is done by the make-decoration
         function.
RETURN:  The decorated list.
"
    (cond
      ((null  cell) +nil-decoration+)
      ((consp cell)
       (let ((dec (make-instance 'cons-decoration
                      :cell cell
                      :car (decorate (car cell))
                      :cdr (decorate (cdr cell)))))
         ;; Coordinates:                  ;
         ;;   #---+---+                   ;
         ;;   $NIL| * |-->      # = (0,0) ;  $ = (0,-1) ;
         ;;   +---+---+                   ;
         (when (cdr cell)
           ;; let's compute relative coordinates of (cdr cell) ;
           (setf (x (cdr-deco dec)) 12
                 (y (cdr-deco dec)) 0))
         (when (car cell)
           ;; slightly more complex: if width of (car cell) is > 12 ;
           ;; then move it down under the (cdr cell), unless it's null. ;
           (if (or (null (cdr cell)) (<= (w (car-deco dec)) 12))
               ;; no problem:             ;
               (setf (x (car-deco dec)) 0
                     (y (car-deco dec)) -5)
               (setf (x (car-deco dec)) 0
                     (y (car-deco dec)) (min -5 (- (y (cdr-deco dec))
                                                   (h (cdr-deco dec))
                                                   1)))))
         (setf (w dec) (if (null (cdr cell))
                           (max (+ (x (car-deco dec)) (w (car-deco dec))) 9)
                           (max (+ (x (car-deco dec)) (w (car-deco dec)))
                                (+ (x (cdr-deco dec)) (w (cdr-deco dec)))))
               (h dec) (if (null (car cell))
                           (max (- (h (cdr-deco dec)) (y (cdr-deco dec))) 3)
                           (max (- (h (car-deco dec)) (y (car-deco dec)))
                                (- (h (cdr-deco dec)) (y (cdr-deco dec))))))
         dec))
      (t (make-instance 'atom-decoration :atom cell))))


  (defmethod draw-cons ((pict picture) x y cell)
    ;; @---+---+                          ;
    ;; | * |NIL|    @ = (0,0)             ;
    ;; +---+---+                          ;
    (frame-rect pict    x    (- y 2) 5 3)
    (frame-rect pict (+ x 4) (- y 2) 5 3)
    (draw-string pict (+ x 1) (1- y) (if (car cell) " * " "NIL"))
    (draw-string pict (+ x 5) (1- y) (if (cdr cell) " * " "NIL"))
    pict)


  (defmethod draw-cell ((pict picture) x y cell)
    (draw-decorated-cell pict x y  (decorate cell)))


  (defmethod draw-decorated-cell ((pict picture) x y (dec atom-decoration))
    (let ((rep (format nil "~S" (atom-value dec))))
      (frame-rect pict x (- y (h dec) -1) (w dec) (h dec))
      (draw-string pict (+ x 2) (- y 1) rep)))


  (defmethod draw-decorated-cell ((pict picture) x y (dec cons-decoration))
    ;; +---+---+   +---+---+   +---+---+   +---+---+ ;
    ;; | * | * |-->| * | * |-->| * | * |-->| * |NIL| ;
    ;; +---+---+   +---+---+   +---+---+   +---+---+ ;
    ;;   |           |           |           | ;
    ;;   V           V           |           V ;
    ;; +---+       +----+        |         +---+---+   +------+ ;
    ;; | A |       | 42 |        |         |NIL| * |-->| :FIN | ;
    ;; +---+       +----+        |         +---+---+   +------+ ;
    ;;                           V        ;
    ;;                         +--------------------+ ;
    ;;                         | "Es una cabronada" | ;
    ;;                         +--------------------+ ;
    ;;(if (<= (length cell) (truncate (width pict) +cell-width+)) ;
    ;; horizontal                         ;
    (draw-cons pict x y (cell-value dec))
    (when (cdr (cell-value dec))
      (draw-arrow pict (+ x 9) (- y 1) 2 0)
      (draw-decorated-cell pict
                           (+ x (x (cdr-deco dec)))
                           (+ y (y (cdr-deco dec)))
                           (cdr-deco dec)))
    (when (car (cell-value dec))
      (draw-arrow pict (+ x 2) (- y 3) 0 (+ (y (car-deco dec)) 4))
      (draw-decorated-cell pict
                           (+ x (x (car-deco dec)))
                           (+ y (y (car-deco dec)))
                           (car-deco dec))))


  (defun draw-list (list &key (title ""))
    (let* ((dec (decorate list))
           (tw 0)
           (th 0)
           (pic))
      (multiple-value-setq (tw th) (size-string +picture-instance+ title))
      (setf th (abs th))
      (setf pic (make-instance 'picture
                    :width  (+ 4 (max tw (w dec)))
                    :height (+ 4 th (h dec))))
      (frame-rect pic 0 0 (width pic) (height pic))
      (when title
        (draw-string pic 2 (- (height pic) 2) title))
      (draw-decorated-cell pic 2 (- (height pic) 4 th) dec)
      pic))


  (defun transpose-tree (tree)
    (if (atom tree)
        tree
        (cons (transpose-tree (cdr tree))  (transpose-tree (car tree)))))




  #||                                     ;
  (load "~/src/common/common-lisp/picture.lisp")
  (use-package "COM.INFORMATIMAGO.COMMON-LISP.PICTURE")

  (SETQ P (MAKE-instance 'PICTURE :width 72 :height 20 :background " "))
  (frame-rect p 0 0 72 20)
  (draw-string p  30 10 (format nil "Hello~%world~%howdy?"))


  (dolist (dir  '(:E :ENE :NE :NNE :N :NNW :NW :WNW :W :WSW :SW :SSW :S :SSE :SE :ESE)) (progn  (SETQ P (frame-rect (MAKE-instance 'PICTURE :width 72 :height 30 :background " ") 0 0 72 30)) (draw-string p (setq x 30) (setq y 15) (setq s (format nil "Hello.~%world~%howdy?")) :direction dir) (multiple-value-bind (l b w h) (size-string p s :direction dir) (frame-rect p (+ x l -1)  (+ y b -1) (+ w 2) (+ h 2)) (draw-string p 1 1 (list :l l :b b :w w :h h)) (draw-string p 1 2 (list :x (+ x l) :y (+ y b) :w  w :h  h)) (draw-line p 3 15 4 0) (fill-rect p 3 8 4 4 :foreground "*") (frame-rect p 1 6 8 8) (frame-rect p 10 8 4 4)(print p))))


  (progn
  (SETQ P (frame-rect (MAKE-instance 'PICTURE :width 72 :height 30 :background " ") 0 0 72 30))
  (draw-arrow p 14 4 -10 0)
  (draw-arrow p 15 4 0 -2 :tail "*")
  (draw-arrow p 20 10 10 0 )
  (draw-arrow p 20 10 0 8 :tail "+")
  p)

  (decorate '((a b) (42 "hello" (:a b)) #(1 2 3 4 5 6)))
  (draw-list '((a b) (42 "hello" (:a b)) #(1 2 3 4 5 6)) "Sample")

  (progn
  (SETQ P (frame-rect (MAKE-instance 'PICTURE :width 72 :height 30 :background " ") 0 0 72 30))
  (draw-cell p 2 25 '((a b) (42 "hello" (:a b)) #(1 2 3 4 5 6)))
  p)


  (draw-list #1='((a b) (42 "hello" (:a b)) #(1 2 3 4 5 6)) :title (format nil "~S" #1#))


  (draw-list #1='(defun fact (n) (if (< 1 n) (* n (fact (1- n))) 1)) :title (format nil "~S" #1#))

  (draw-list #1='(defun square (n) (* n n)) :title (format nil "~S" #1#))

  ||#



  (defun print-tree (tree &optional (stream *standard-output*))
    ;; WARNING: doesn't handle circles nor identify EQ subtrees. ;
    (cond
      ((null tree) (princ "()"))
      ((atom tree) (princ tree stream))
      (t (princ "(" stream)
         (dolist (item (butlast tree))
           (print-tree item stream)
           (princ " " stream))
         (print-tree (car (last tree)) stream)
         (princ ")" stream)))
    tree)


  (defun print-conses (tree &optional (stream *standard-output*))
    ;; WARNING: doesn't handle circles nor identify EQ subtrees. ;
    (cond
      ((null tree) (princ "()"))
      ((atom tree)  (princ tree stream) (princ " " stream))
      (t (princ "(" stream)
         (print-conses (car tree) stream)
         (princ " . " stream)
         (print-conses (cdr tree) stream)
         (princ ")" stream)))
    tree)



  #||                                     ;
  [31]> (print-conses '(a b c))
  (A  . (B  . (C  . ())))
  (A B C)
  [32]> (print-conses '((a) (b) (c)))
  ((A  . ()) . ((B  . ()) . ((C  . ()) . ())))
  ((A) (B) (C))
  ||#



  (defun find-nodes (tree table)
    (cond
      ((null tree) table)
      ((gethash tree table) (incf (gethash tree table))   table)
      ((atom tree)          (incf (gethash tree table 0)) table)
      (t (incf (gethash tree table 0))
         (find-nodes (cdr tree) (find-nodes (car tree) table)))))


  (defun print-identified-conses (tree  &optional (stream *standard-output*))
    (let ((table (find-nodes tree (make-hash-table :test (function eq))))
          (index 0))
      (maphash (lambda (k v)
                 (if (= 1 v)
                     (remhash k table)
                     (setf (gethash k table) (- (incf index))))) table)
      (labels ((print-node (node)
                 (if (null node)
                     (princ "()")
                     (let ((index (gethash node table)))
                       (if (and index (plusp index))
                           (format stream "#~A# " index)
                           (progn
                             (when index
                               (setf (gethash node table) (- index))
                               (format stream "#~A=" (- index)))
                             (if (atom node)
                                 (princ node stream)
                                 (progn
                                   (princ "(" stream)
                                   (print-node (car node))
                                   (princ " . " stream)
                                   (print-node (cdr node))
                                   (princ ")" stream)))))))))
        (print-node tree)
        tree)))


  #||                                     ;
  (defparameter tree '#2=(#1=(a) (b c a #1# #2#) . #2#))
  (setf *print-circles* t)
  (print-identified-conses tree)
  #3=(#2=(#1=A . ()) . ((B . (C . (#1#  . (#2#  . (#3#  . ()))))) . #3# ))
  #1=(#2=(A) (B C A #2# #1#) . #1#)


  ||#


  )



;; (generate (make-instance
;;               'cons-node :object '(#2="Abcdef" . #4=(#3=123456 . nil))
;;               :car (generate (make-instance
;;                                  'atom-node :object '#2#) *standard-output*)
;;               :cdr (generate (make-instance
;;                                  'cons-node :object '#4#
;;                                  :car (generate (make-instance
;;                                                     'atom-node :object #3#) *standard-output*)
;;                                  :cdr nil) *standard-output*))
;;           *standard-output*)


(setf  *vector-length* 3)
(generate
 (make-instance
     'vector-node
     :object (vector
              #11='(#2="Abcdef" . #4=(#3=123456 . nil))
              #12='"Second element"
              #13='3333
              #14='"The Fourth Element")
     :slots (vector
             (generate
              (make-instance
                  'cons-node :object #11#
                  :car (generate
                        (make-instance 'atom-node :object '#2#)
                        *standard-output*)
                  :cdr (generate
                        (make-instance
                            'cons-node :object '#4#
                            :car (generate
                                  (make-instance 'atom-node :object #3#)
                                  *standard-output*)
                            :cdr nil)
                        *standard-output*))
              *standard-output*)
             (generate (make-instance 'atom-node :object #12#) *standard-output*)
             (generate (make-instance 'atom-node :object #13#) *standard-output*)
             (generate (make-instance 'atom-node :object #14#) *standard-output*)))
 *standard-output*)



(package:add-nickname :com.informatimago.common-lisp.cons-to-ascii :cta)
;;;; THE END :;;;
ViewGit