;;; -*- coding:utf-8 -*-
;;;;****************************************************************************
;;;;FILE:               cons-to-ascii.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    This packages draws ASCII art cons cell diagrams.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    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.CONS-TO-ASCII"
  (:use "COMMON-LISP"
        "SPLIT-SEQUENCE"
        "COM.INFORMATIMAGO.COMMON-LISP.PICTURE"
        "COM.INFORMATIMAGO.COMMON-LISP.STRING" )
  (:export "PRINT-IDENTIFIED-CONSES" "PRINT-CONSES" "DRAW-CELL" "DRAW-LIST")
  (:documentation
   "This packages draws ASCII art cons cell 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.CONS-TO-ASCII")




(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))))




(defgeneric draw (thing device)
  (:documentation "
DO:     Draws the THING on the given DEVICE.
RETURN: DEVICE.
"))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GEOMETRY


;;; SIZE
;; A simple 2D vectorial space.

(defclass size ()
  ((w :accessor w :initarg :w :initform 0)
   (h :accessor h :initarg :h :initform 0)))

(defun size (w h) (make-instance 'size :w w :h h))

(defmethod size+ ((a size) (b size)) (size (+ (w a) (w b)) (+ (h a) (h b))))
(defmethod size- ((a size) (b size)) (size (- (w a) (w b)) (- (h a) (h b))))
(defmethod size* ((a size) (s real)) (size (* (w a) s) (* (h a) s)))
(defmethod size/ ((a size) (s real)) (size (/ (w a) s) (/ (h a) s)))


;;; POINT
;; A 2D afine space.

(defclass point ()
  ((x :accessor x :initarg :x :initform 0)
   (y :accessor y :initarg :y :initform 0)))

(defun point (x y) (make-instance 'point :x x :y y))

(defmethod point+ ((a point) (b size))   (point (+ (x a) (w b)) (+ (y a) (h b))))
(defmethod point- ((a point) (b point))  (size (- (x a) (x b)) (- (y a) (y b))))




;;; LINE

(defclass line ()
  ((points :accessor points :initarg :points :initform '() :type list)))

(defun line (&rest points)
  (make-instance 'line :points (copy-list points)))

(defmethod draw ((self line) (pict picture))
  (loop
     :with w = 0
     :with h = 0
     :for first-point = t :then nil
     :for (from to) :on (points self) :by (function cdr)
     :do (if to
           (progn
             (setf w  (- (x to) (x from))
                   h  (- (y to) (y from)))
             (draw-line pict (x from) (y from) w h
                        :foreground (cond
                                      ((zerop w) "|")
                                      ((zerop h) "-")
                                      ((plusp (* w h)) "/")
                                      (t               "\\")))
             (unless first-point
               (draw-point pict (x from) (y from) "+")))
           (draw-point pict (x from) (y from)
                       (if (zerop w)
                         (if (plusp h) "^" "v")
                         (if (plusp w) ">" "<")))))
  pict)


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

(defclass node ()
  ((object :accessor node-object :initarg :object :initform nil :type t)
   (x      :accessor x :initarg :x :initform 0 :type integer)
   (y      :accessor y :initarg :y :initform 0 :type integer)
   (w      :accessor w :initarg :w :initform 0 :type integer)
   (h      :accessor h :initarg :h :initform 0 :type integer)
   (refcount :reader node-refcount :initform 1 :type integer))
  (:documentation "An abstract graphic node, representing some ATOM or CONS."))

(define-print-object ((self node) stream)
    (list :object (node-object self) :w (w self) :h (h self) :x (x self) :y (y self)
          :refcount (node-refcount self)))

(defmethod add-reference ((self node))
  (incf (slot-value self 'refcount))
  self)



(defgeneric compute-node-size (node device)
  (:documentation "Compute the size (W,H) of the NODE, to be drawn on
the given DEVICE.  This may also set the position of the sub nodes,
but this is subject to the routing algorithm."))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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 |
       +--------------+
"))


(defgeneric compute-lines (node))
(defmethod compute-lines ((self t))
  '())
(defmethod compute-lines ((self atom-node))
  (if (slot-boundp self 'lines)
    (slot-value self 'lines)
    (setf (slot-value self 'lines)
          (split-sequence #\newline (prin1-to-string (node-object self))))))


(defmethod compute-node-size ((self atom-node) (pict picture))
  (setf (w self) (+ 4 (reduce (function max) (compute-lines self) :key (function length)))
        (h self) (+ 2 (length (compute-lines self))))
  self)

(defmethod draw ((self atom-node) (pict picture))
  (loop
     :with x = (+ (x self) 2)
     :for y :from (- (y self) 1) :by -1
     :for line :in (compute-lines self)
     :initially (frame-rect pict (x self) (- (y self) (h self) -1) (w self) (h self))
     :do (draw-string pict x y line))
  pict)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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.
"))

(define-print-object ((self cons-node) stream) (list :car (car-node self) :cdr (cdr-node self)))


(defmethod compute-node-size ((self cons-node) (pict picture))
  (setf (w self) 9
        (h self) 3)
  self)

(defmethod draw ((self cons-node) (pict picture))
  ;; @---+---+                          ;
  ;; | * |NIL|    @ = (0,0)             ;
  ;; +---+---+                          ;
  (with-slots ((x x) (y y) (object object)) self
    (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 object) " * " "NIL"))
    (draw-string pict (+ x 5) (1- y) (if (cdr object) " * " "NIL")))
  pict)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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.
"))

(define-print-object ((self vector-node) stream) (list :slots (slot-nodes self)))


(defmethod compute-node-size ((self vector-node) (pict picture))
  (let* ((len  (length (node-object self)))
         (llen (ceiling (log len 10))))
    (when (and *vector-length*
             (< (max 3 *vector-length*) len))
      (setf len (max 3 *vector-length*)))
    (setf (w self) (+ llen 6)
          (h self) (+ 1 (* 2 len))))
  self)


(defmethod draw ((self vector-node) (pict picture))
  (with-slots ((x x) (y y) (w w) (h h) (object object)) self
    (loop
       :with len  = (length object)
       :with llen = (ceiling (log len 10))
       :for i :from 0 :below (if *vector-length*
                               (min (- *vector-length* 2) len)
                               len)
       :initially (frame-rect pict x (- y h -2) (+ w 2) h)
       :do (progn
             (draw-string pict (1+ x) (- y (* 2 i)) (format nil " ~VD" llen i))
             (frame-rect  pict (+ x llen 3)  (- y (* 2 i) 1) 5 3)
             (draw-string pict (+ x llen 4)  (- y (* 2 i))
                          (if (aref object i) " * " "NIL")))
       :finally (when (and *vector-length* (< (max 3 *vector-length*) len))
                  (draw-string pict (+ x llen 4) (- y (* 2 (- *vector-length* 2)))
                               "...")
                  (draw-string pict (1+ x) (- y (* 2 (1- *vector-length*)))
                               (format nil " ~VD" llen (1- len)))
                  (frame-rect  pict (+ x llen 3)  (- y (* 2 (1- *vector-length*)) 1) 5 3)
                  (draw-string pict (+ x llen 4)  (- y (* 2 (1- *vector-length*)))
                               (if (aref object (1- len)) " * " "NIL")))))
  pict)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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 compute-node-size ((self structure-node) (pict picture))
  (let* ((len  (slot-count (node-structure self)))
         (llen (1+ (reduce (function max)
                           (structure-slots (node-structure self))
                           :key (lambda (slot-desc) (length (string (slot-name slot-desc))))))))
    (when (and *structure-length*
             (< (max 3 *structure-length*) len))
      (setf len (max 3 *structure-length*)))
    (setf (w self) (max (length (string (structure-name (node-structure self))))
                        (+ llen 7))
          (h self) (+ 1 (* 2 len))))
  self)


(defmethod draw ((self structure-node) (pict picture))
  (with-slots ((x x) (y y) (w w) (h h) (object object)) self
    (loop
       :with len  = (slot-count (node-structure self))
       :with llen = (1+ (reduce (function max)
                                (structure-slots (node-structure self))
                                :key (lambda (slot-desc) (length (string (slot-name slot-desc))))))
       :for i :from 0 :below (if *structure-length*
                               (min (- *structure-length* 2) len)
                               len)
       :for slot-desc = (slot-ref (node-structure self) i)
       :initially (progn
                    ;; Draw the structure name!
                    (frame-rect pict x (- y h -2) w h))
       :do (progn
             (draw-string pict (1+ x) (- y (* 2 i))
                          (format nil "~VD:" llen (slot-name slot-desc)))
             (frame-rect  pict (+ x llen 3)  (- y (* 2 i) 1) 5 3)
             (draw-string pict (+ x llen 4)  (- y (* 2 i))
                          (if (funcall (slot-reader slot-desc) object) " * " "NIL")))
       :finally (when (and *structure-length* (< (max 3 *structure-length*) len))
                  (let ((slot-desc (slot-ref (node-structure self) (1- *structure-length*))))
                    (draw-string pict (+ x llen 4) (- y (* 2 (- *structure-length* 2)))
                                 "...")
                    (draw-string pict (1+ x) (- y (* 2 i))
                                 (format nil "~VD:" llen (slot-name slot-desc)))
                    (frame-rect  pict (+ x llen 3)  (- y (* 2 (1- *vector-length*)) 1) 5 3)
                    (draw-string pict (+ x llen 4)  (- y (* 2 (1- *vector-length*)))
                                 (if (funcall (slot-reader slot-desc) object) " * " "NIL"))))))
  pict)


#||
(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#)


  ||#


  )

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