(asdf-load :alexandria :split-sequence :vecto)
(use-package :alexandria)
(shadow 'rotate)
(use-package :split-sequence)
(use-package :vecto)



;;;------------------------------------------------------------
;;; Units
;;;------------------------------------------------------------

(defun cm  (x) "Convert the centimeters into inches." (/ x 2.54))
(defun pt  (x) "Convert the points      into inches." (/ x 72.0))
(defun in  (x) "Convert the inches      into inches." x)
(defun dpi (x) "dot per inch"                         x)

(defun inch-to-pt (x) (* x 72.0))
(defun inch-to-cm (x) (* x 2.54))
(defun inch-to-mm (x) (* x 25.4))

(defgeneric inch-to-unit (x unit)
  (:method (x (unit (eql :in))) x)
  (:method (x (unit (eql :pt))) (inch-to-pt x))
  (:method (x (unit (eql :cm))) (inch-to-cm x))
  (:method (x (unit (eql :mm))) (inch-to-mm x)))


;;;------------------------------------------------------------
;;; POINT
;;;------------------------------------------------------------
;;; POINTs are used both as vectors and affine points.

(defstruct point
  (x  0.0)
  (y  0.0))


(defmethod above ((self point) &optional (offset 0))
  (make-point :x (point-x self) :y (+ (point-y self) offset)))

(defmethod below ((self point) &optional (offset 0))
  (make-point :x (point-x self) :y (- (point-y self) offset)))

(defmethod left-of ((self point) &optional (offset 0))
  (make-point :x (- (point-x self) offset) :y (point-y self)))

(defmethod right-of ((self point) &optional (offset 0))
  (make-point :x (+ (point-x self) offset) :y (point-y self)))



(defun vector+ (a b)
  (make-point :x (+ (point-x b) (point-x a))
              :y (+ (point-y b) (point-y a))))

(defun vector- (a b)
  (make-point :x (- (point-x a) (point-x b))
              :y (- (point-y a) (point-y b))))

(defun square (x) (* x x))

(defun distance-squared (p q)
  (+ (square (- (point-x p) (point-x q)))
     (square (- (point-y p) (point-y q)))))

(defun vector-abs (vec)
  (sqrt (+ (square (point-x vec))
           (square (point-y vec)))))

(defun vector* (scalar vec)
  (make-point :x (* scalar (point-x vec))
              :y (* scalar (point-y vec))))

(defun vector-rotate (vec angle)
  (let ((s (sin angle))
        (c (cos angle)))
    (make-point :x (- (* c (point-x vec)) (* s (point-y vec)))
                :y (+ (* s (point-x vec)) (* c (point-y vec))))))

(defun unit-vector (v)
  (vector* (/ (vector-abs v)) v))


;;;------------------------------------------------------------
;;; Generic Functions
;;;------------------------------------------------------------

(defgeneric origin (object)
  (:documentation "The point origin of the coordinates of the ``OBJECT``."))

(defgeneric (setf origin) (new-value object)
  (:documentation "Change the origin of the ``OBJECT``."))

(defgeneric bounds (object)
  (:documentation "
The rectangle surrounding the ``OBJECT``, in the coordinate system
relative to the ``ORIGIN``.
"))

(defgeneric frame (object)
  (:documentation "
The rectangle surrounding the ``OBJECT``, in the coordinate system
where the object is drawn (same coordinate system in which ``ORIGIN`` is
expressed). ::

    (frame object) == (rect-offset (bounds object)
                                   (point-x (origin object))
                                   (point-y (origin object)))

")
  (:method (object)
    (rect-offset (bounds object)
                 (point-x (origin object))
                 (point-y (origin object)))))

(defgeneric place (object point)
  (:documentation "Change the origin of the ``OBJECT`` to be the ``POINT``.")
  (:method (object (to point))
    (setf (origin object) to)
    object))


;;;------------------------------------------------------------
;;; RECT & SIZE
;;;------------------------------------------------------------

(defstruct size
  (width  0.0)
  (height 0.0))


(defclass rect ()
  ((origin :initform (make-point) :type point :initarg :origin :accessor origin :accessor rect-origin)
   (size   :initform (make-size)  :type size  :initarg :size   :accessor size   :accessor rect-size)))

(defmethod print-object ((self rect) stream)
  (print-unreadable-object (self stream :identity nil :type t)
    (let ((*print-circle* nil))
      (format stream "~S"
              ;; ":origin (make-point :x ~A :y ~A) :width (make-size :width ~A :height ~A)"
              (list :x (point-x (rect-origin self))
                    :y (point-y (rect-origin self))
                    :width (size-width  (rect-size self))
                    :height (size-height (rect-size self))))))
  self)

;; There's a draw method on RECT, but it's not a drawable: it's not
;; put on the *draw-list* when created, and it's bound is fixed at its
;; origin.

(defun make-rect (&key (origin (make-point)) (size (make-size)))
  (make-instance 'rect :origin origin :size size))


(defun rect-left   (r) (point-x (rect-origin r)))
(defun rect-bottom (r) (point-y (rect-origin r)))
(defun rect-width  (r) (size-width  (rect-size r)))
(defun rect-height (r) (size-height (rect-size r)))
(defun rect-right  (r) (+ (point-x (rect-origin r)) (rect-width  r)))
(defun rect-top    (r) (+ (point-y (rect-origin r)) (rect-height r)))
(defun rect-horizontal-center (r) (+ (point-x (rect-origin r)) (/ (size-width  (rect-size r)) 2)))
(defun rect-vertical-center   (r) (+ (point-y (rect-origin r)) (/ (size-height (rect-size r)) 2)))

(defun rect-union (a b)
  (let ((origin  (make-point :x (min (rect-left a) (rect-left b))
                             :y (min (rect-bottom a) (rect-bottom b)))))
    (make-rect :origin origin
               :size (make-size :width  (- (max (rect-right a) (rect-right b)) (point-x origin))
                                :height (- (max (rect-top   a) (rect-top   b)) (point-y origin))))))

(defun rect-offset (r dx dy)
  (make-rect :origin (make-point :x (+ dx (point-x (rect-origin r)))
                                 :y (+ dy (point-y (rect-origin r))))
             :size (rect-size r)))





(defmethod origin ((self rect))
  (rect-origin self))

(defmethod (setf origin) (new-value (self rect))
  (setf (rect-origin self) to))

(defmethod frame ((self rect))
  self)


(defmethod bounds ((self rect))
  (make-rect :size (rect-size self)))


(defmethod place ((self rect) (to point))
  (setf (rect-origin self) to)
  self)


(defmethod above ((self rect) &optional (offset 0))
  (make-point :x (rect-left self)
              :y (+ (rect-top self) offset)))

(defmethod below ((self rect) &optional (offset 0))
  (make-point :x (rect-left self)
              :y (- (rect-bottom self) offset)))

(defmethod left-of ((self rect) &optional (offset 0))
  (make-point :x (- (rect-left self) offset)
              :y (rect-bottom self)))

(defmethod right-of ((self rect) &optional (offset 0))
  (make-point :x (+ (rect-right self) offset)
              :y (rect-bottom self)))



(defmethod draw ((self rect))
  (let ((left   (rect-left   self))
        (right  (rect-right  self))
        (top    (rect-top    self))
        (bottom (rect-bottom self)))
    (move-to left bottom)
    (line-to left top)
    (line-to right top)
    (line-to right bottom)
    (line-to left bottom)
    (close-subpath)
    (stroke)))




(defun stack-objects (objects &key (direction :up) (align :left) (spacing 0))
  "
Stack up or down the ``OBJECTS`` based on the position of the first one.
"
  (when objects
    (let* ((frame (frame (first objects)))
           (x  (ecase align
                 (:left   (rect-left              frame))
                 (:right  (rect-right             frame))
                 (:center (rect-horizontal-center frame))))
           (y  (ecase direction
                 (:up   (rect-top    frame))
                 (:down (rect-bottom frame)))))
      (loop
         :for object :in (rest objects)
         :for frame = (frame object)
         :do (when (eq direction :down)
               (decf y (+ spacing (rect-height frame))))
         :do (place object (ecase align
                             (:left   (make-point :x x                               :y y))
                             (:right  (make-point :x (- x (rect-width frame))       :y y))
                             (:center (make-point :x (- x (/ (rect-width frame) 2)) :y y))))
         :do (when (eq direction :up)
               (incf y (+ spacing (rect-height frame)))))))
  objects)

(defun stack-up (objects &key (align :left) (spacing 0))
  (stack-objects objects :direction :up :align align :spacing spacing))

(defun pile-down (objects &key (align :left) (spacing 0))
  (stack-objects objects :direction :down :align align :spacing spacing))



;;;------------------------------------------------------------
;;; PAGE
;;;------------------------------------------------------------

(defstruct page
  size-pixel
  size-inch
  horizontal-density
  vertical-density)

(defun page (&key width height density horizontal-density vertical-density)
  (let ((horizontal-density (or horizontal-density  density))
        (vertical-density   (or vertical-density    density)))
    (make-page :size-pixel (make-size :width  (round (* width  horizontal-density))
                                      :height (round (* height vertical-density)))
               :size-inch  (make-size :width  width
                                      :height height)
               :horizontal-density  horizontal-density
               :vertical-density    vertical-density)))

(defun rotate-page (page)
  (page :width  (size-height (page-size-inch page))
        :height (size-width  (page-size-inch page))
        :horizontal-density  (page-vertical-density   page)
        :vertical-density    (page-horizontal-density page)))


(defmacro with-page ((page &key (unit :pt)) &body body)
  (with-gensyms (vpage vunit vsize)
    `(let* ((,vpage ,page)
            (,vunit ,unit)
            (,vsize (page-size-pixel ,vpage)))
       (with-canvas (:width (size-width ,vsize) :height (size-height ,vsize))
         (scale  (/ (page-horizontal-density ,vpage)
                    (inch-to-unit 1 ,vunit))
                 (/ (page-vertical-density ,vpage)
                    (inch-to-unit 1 ,vunit)))
         (locally ,@body)))))


(defparameter *a4*   (page :width (cm 21.0) :height (cm 29.7) :density (dpi 300)))


;;;------------------------------------------------------------
;;; COLOR
;;;------------------------------------------------------------

(defstruct color
  (red   0.0)
  (green 0.0)
  (blue  0.0)
  (alpha 1.0))

(defvar *white*    (make-color :red 1.0 :green 1.0 :blue 1.0))
(defvar *red*      (make-color :red 1.0 :green 0.0 :blue 0.0))
(defvar *green*    (make-color :red 0.0 :green 1.0 :blue 0.0))
(defvar *blue*     (make-color :red 0.0 :green 0.0 :blue 1.0))
(defvar *yellow*   (make-color :red 1.0 :green 1.0 :blue 0.0))
(defvar *magneta*  (make-color :red 1.0 :green 0.0 :blue 1.0))
(defvar *cyan*     (make-color :red 0.0 :green 1.0 :blue 1.0))
(defvar *black*    (make-color :red 0.0 :green 0.0 :blue 0.0))


(defun set-fill-color (color)
  (set-rgba-fill (color-red color)
                 (color-green color)
                 (color-blue color)
                 (color-alpha color)))

(defun set-stroke-color (color)
  (set-rgba-stroke (color-red color)
                   (color-green color)
                   (color-blue color)
                   (color-alpha color)))


;;;------------------------------------------------------------
;;; PORT
;;;------------------------------------------------------------

(defclass port ()
  ((drawable :initarg :drawable :accessor port-drawable)
   (tags     :initarg :tags     :accessor port-tags :initform '())
   (point    :initarg :point    :accessor port-point))
  (:documentation "
A ``PORT`` is a point on a ``DRAWABLE`` from or to which an arrow can
be drawn.  Each port is tagged with keywords representing its meaning
and/or position, so that they can be selected symbolically.

Tags may contain keywords such as:

    Direction

        (member :in :out)

    Position

        (member :top :left :bottom :right :center)

    Part

        (member :whole :car :cdr)

"))

(defmethod print-object ((self port) stream)
  (print-unreadable-object (self stream :identity t :type t)
    (format stream "~S"
            (list :drawable (when (slot-boundp self 'drawable) (port-drawable self))
                  :tags     (when (slot-boundp self 'tags)     (port-tags self))
                  :point    (when (slot-boundp self 'point)    (port-point self)))))
  self)


(defmethod port-tags-match-p ((self port) tags)
  (subsetp tags (intersection tags (port-tags self))))


(defun port-offset (port point)
  (make-instance 'port
      :drawable (port-drawable port)
      :tags (port-tags port)
      :point (vector+ point (port-point port))))


;;;------------------------------------------------------------
;;; DRAWABLE
;;;------------------------------------------------------------


(defvar *draw-list* '()
  "Each drawable object created is collected on this list for easy draw.")

(defvar *old-draw-list* '()
  "For debugging purpose, the old draw list is kept here (in order drawn, ie. reversed).")

(defvar *font*)
(defvar *font-size* 12.0)

(defun string-width (string)
  (ceiling (aref (string-bounding-box string *font-size* *font*) 2)))

(defun bounding-box-to-rect (box)
  (let ((left   (aref box 0))
        (bottom (aref box 1))
        (right  (aref box 2))
        (top    (aref box 3)))
    (make-rect :origin (make-point :x left :y bottom)
               :size (make-size :width (- right left)
                                :height (- top bottom)))))



(defun drawable (instance)
  "
The ``INSTANCE`` should be a ``DRAWABLE`` instance.  It is pushed onto
the ``*DRAW-LIST*`` which is used by the ``DRAW-OBJECT`` function,

Return the drawable ``INSTANCE``.
"
  (push instance *draw-list*)
  instance)


(defun remove-draw-object (object)
  (setf *draw-list* (remove object *draw-list*))
  object)


(defun draw-objects ()
  "
Draws all the objects in the ``*DRAW-LIST*`` (in the reverse order).
The ``*DRAW-LIST*`` is reset to the empty list before drawing.

For debugging purposes, the reversed ``*DRAW-LIST*`` is bound to
``*OLD-DRAW-LIST*``.
"
  (let ((objects (nreverse *draw-list*)))
    (setf *old-draw-list* objects
          *draw-list* '())
    (map nil 'draw objects)))



(defclass drawable ()
  ((origin  :initarg :origin  :initform (make-point) :accessor origin
            :documentation "
The ``ORIGIN`` of the drawable, given in the coordinate system in
which the drawable is drawn.  When the drawable is moved only the
``ORIGIN`` is changed.
")
   (bounds  :initarg :bounds  :initform nil :accessor bounds
            :documentation "
The ``BOUNDS`` of the drawable, that is, the rectangle surrounding the
drawn parts of the drawable, given in coordinates relative to the
drawable ``ORIGIN``.
")
   (ports   :initarg :ports   :initform '() :accessor ports
            :documentation "
A list of ports.

Ports represent points relative to the origin of their drawable, where
arrows can come from or arrive to the drawn cell.
")))


(defmethod tags ((self drawable))
  "
Return the set of tags available for generic DRAWABLE instances.
This is the union of all tags of all ports of the drawable.
"
  (declare (ignore self))
  '(:in :out :whole :center))


(defmethod adjust-size  ((self drawable))
  "
Compute and update the ``BOUNDS`` and ``PORTS``.
For an abstract ``DRAWABLE``, we don't change the ``BOUNDS``.
"
  (setf (slot-value self 'ports)
        (let* ((bounds (bounds self))
               (height (rect-height bounds))
               (width  (rect-width  bounds)))
          (list (make-instance 'port :drawable self :point (make-point :x (truncate width 2) :y  (truncate height 2)) :tags '(:in :out :whole :center)))))
  self)


(defmethod ports ((self drawable))
  (unless (slot-value self 'ports)
    (adjust-size self))
  (slot-value self 'ports))


(defmethod (setf bounds) (new-value (self drawable))
  "
When ``BOUNDS`` of a drawable are changed, we update automatically the
ports.
"
  (setf (slot-value self 'ports)  nil
        (slot-value self 'bounds) new-value))


(defmethod above ((self drawable) &optional (offset 10))
  "
Return a point that is offset units above the top of the drawable
relative to its origin.
"
  (let ((bounds (bounds self)))
    (make-point :x (point-x (origin self))
                :y (+ (point-y (origin self))
                      (+ (rect-top bounds) offset)))))


(defmethod below ((self drawable) &optional (offset 10))
  "
Return a point that is offset units below the bottom of the drawable
relative to its origin.
"
  (let ((bounds (bounds self)))
    (make-point :x (point-x (origin self))
                :y (+ (point-y (origin self))
                      (- (rect-bottom bounds) offset)))))


(defmethod right-of ((self drawable) &optional (offset 10))
  "
Return a point that is offset units to the right of the right of the
drawable relative to its origin.
"
  (let ((bounds (bounds self)))
    (make-point :x (+ (point-x (origin self))
                      (+ (rect-right bounds) offset))
                :y (point-y (origin self)))))


(defmethod left-of ((self drawable) &optional (offset 10))
  "
Return a point that is offset units to the left of the left of the
drawable relative to its origin.
"
  (let ((bounds (bounds self)))
    (make-point :x (+ (point-x (origin self))
                      (- (rect-left bounds) offset))
                :y (point-y (origin self)))))



;;;------------------------------------------------------------
;;; TRIANGLE
;;;------------------------------------------------------------

(defclass triangle (drawable)
  ((a        :initarg :a        :accessor triangle-point-a)
   (b        :initarg :b        :accessor triangle-point-b)
   (c        :initarg :c        :accessor triangle-point-c)
   (label-a  :initarg :label-a  :accessor triangle-label-a)
   (label-b  :initarg :label-b  :accessor triangle-label-b)
   (label-c  :initarg :label-c  :accessor triangle-label-c)
   (label-ab :initarg :label-ab :accessor triangle-label-ab)
   (label-bc :initarg :label-bc :accessor triangle-label-bc)
   (label-ca :initarg :label-ca :accessor triangle-label-ca))
  (:documentation "
A triangle defined by its three vertices, A, B, and C.
The vertices and the sides can be labelled.

The ``ORIGIN`` and ``BOUNDS`` of a ``TRIANGLE`` are computed lazilly
from the vertices.
"))


(defmethod initialize-instance ((self triangle) &rest initargs &key &allow-other-keys)
  (declare (ignorable initargs))
  (call-next-method)
  (setf (slot-value self 'origin) nil
        (slot-value self 'bounds) nil
        (slot-value self 'ports)  nil)
  self)


(defmethod print-object ((self triangle) stream)
  (print-unreadable-object (self stream :identity t :type t)
    (let ((*print-circle* nil))
      (format stream "~S"
              (append
               (list :origin (slot-value self 'origin)
                     :bounds (slot-value self 'bounds)
                     :frame  (frame self)
                     :a (triangle-point-a self)
                     :b (triangle-point-b self)
                     :c (triangle-point-c self))
               (when (slot-boundp self 'label-a)  (list :label-a  (triangle-label-a  self)))
               (when (slot-boundp self 'label-b)  (list :label-b  (triangle-label-b  self)))
               (when (slot-boundp self 'label-c)  (list :label-c  (triangle-label-c  self)))
               (when (slot-boundp self 'label-ab) (list :label-ab (triangle-label-ab self)))
               (when (slot-boundp self 'label-bc) (list :label-bc (triangle-label-bc self)))
               (when (slot-boundp self 'label-ca) (list :label-ca (triangle-label-ca self)))))))
  self)


(defun triangle (&rest arguments &key &allow-other-keys)
  "
Creates and return a new ``TRIANGLE`` instance, putting it on the
``*DRAW-LIST*``.
"
  (drawable (apply (function make-instance) 'triangle arguments)))


(defmethod (setf origin) (new-value (self triangle))
  (origin self) ; compute the origin if not already known.
  (place self new-value))  ; use place to move the triangle.


(defmethod origin ((self triangle))
  "
For a ``TRIANGLE`` instance, the ``BOUNDS`` and ``ORIGIN`` are
computed from the vertices.
"
  (or (slot-value self 'origin)
      (let ((left   (min (point-x (triangle-point-a self))
                         (point-x (triangle-point-b self))
                         (point-x (triangle-point-c self))))
            (bottom (min (point-y (triangle-point-a self))
                         (point-y (triangle-point-b self))
                         (point-y (triangle-point-c self)))))
        (setf (slot-value self 'origin) (make-point :x left :y bottom)))))


(defmethod place ((self triangle) (to point))
  (setf (slot-value self 'a) (vector+ to (vector- (triangle-point-a self) (origin self)))
        (slot-value self 'b) (vector+ to (vector- (triangle-point-b self) (origin self)))
        (slot-value self 'c) (vector+ to (vector- (triangle-point-c self) (origin self)))
        (slot-value self 'origin) nil
        (slot-value self 'bounds) nil
        (slot-value self 'ports)  nil)
  self)



(defmethod (setf bounds) (new-value (self triangle))
  (error "Cannot set the bounds of a triangle.  Set directly the three vertices."))


(defmethod bounds ((self triangle))
  "
For a ``TRIANGLE`` instance, the ``BOUNDS`` and ``ORIGIN`` are
computed from the vertices.
"
  (or (slot-value self 'bounds)
      (let ((left   (min (point-x (triangle-point-a self))
                         (point-x (triangle-point-b self))
                         (point-x (triangle-point-c self))))
            (right  (max (point-x (triangle-point-a self))
                         (point-x (triangle-point-b self))
                         (point-x (triangle-point-c self))))
            (bottom (min (point-y (triangle-point-a self))
                         (point-y (triangle-point-b self))
                         (point-y (triangle-point-c self))))
            (top    (max (point-y (triangle-point-a self))
                         (point-y (triangle-point-b self))
                         (point-y (triangle-point-c self)))))
        (setf (slot-value self 'bounds) (make-rect :size (make-size :width (- right left)
                                                                    :height (- top bottom)))))))



(defmethod (setf triangle-point-a) (new-value (self triangle))
  (setf (slot-value self 'origin) nil
        (slot-value self 'bounds) nil
        (slot-value self 'ports)  nil
        (slot-value self 'a) new-value))

(defmethod (setf triangle-point-b) (new-value (self triangle))
  (setf (slot-value self 'origin) nil
        (slot-value self 'bounds) nil
        (slot-value self 'ports)  nil
        (slot-value self 'b) new-value))

(defmethod (setf triangle-point-c) (new-value (self triangle))
  (setf (slot-value self 'origin) nil
        (slot-value self 'bounds) nil
        (slot-value self 'ports)  nil
        (slot-value self 'c) new-value))



(defun right-angle (origin x y)
  "
Draw the little right-angle symbol in the vertex at ``ORIGIN`` between
the axis ``X`` and ``Y``.
"
  (let* ((u   (unit-vector (vector- x origin)))
         (v   (unit-vector (vector- y origin)))
         (u+v (vector+ u v))
         (s   5)
         (p   (vector+ origin (vector* 5 u)))
         (r   (vector+ origin (vector* 5 u+v)))
         (q   (vector+ origin (vector* 5 v))))
    (move-to (point-x p) (point-y p))
    (line-to (point-x r) (point-y r))
    (line-to (point-x q) (point-y q))
    (stroke)))


(defmethod draw ((self triangle))
  (let* ((a  (triangle-point-a self))
         (b  (triangle-point-b self))
         (c  (triangle-point-c self)))
    (move-to (point-x a) (point-y a))
    (line-to (point-x b) (point-y b))
    (line-to (point-x c) (point-y c))
    (line-to (point-x a) (point-y a))
    (stroke)
    (let ((ab (distance-squared a b))
          (bc (distance-squared b c))
          (ca (distance-squared c a)))
      (when (= ab (+ bc ca)) (right-angle c a b))
      (when (= bc (+ ca ab)) (right-angle a b c))
      (when (= ca (+ ab bc)) (right-angle b c a)))
    (let* ((ab (unit-vector (vector- b a)))
           (bc (unit-vector (vector- c b)))
           (ca (unit-vector (vector- a c)))
           (ap (vector+ a (vector* 10 (vector- ca ab))))
           (bp (vector+ b (vector* 10 (vector- ab bc))))
           (cp (vector+ c (vector* 10 (vector- bc ca)))))
      (flet ((draw-label (label point)
               (when label
                 (draw-string (point-x point) (point-y point) (princ-to-string label)))))
        (draw-label (triangle-label-a self) ap)
        (draw-label (triangle-label-b self) bp)
        (draw-label (triangle-label-c self) cp)))
    ;; Note we don't draw the side labels yet.
    self))





;;;------------------------------------------------------------
;;; CELL
;;;------------------------------------------------------------

(defclass cell (drawable)
  ((address :initarg :address :initform nil :accessor cell-address)
   (labels  :initarg :labels  :initform '() :accessor cell-labels
            :documentation "
A list of label descriptors.

Each label is a list containing the label object, and a keyword
indicating the placement of the label around the cell: ::

   (member :topleft :top :topright :right :bottomright :bottom :bottomleft :left)

Notice the :bottomleft emplacement is already used by the address if
not NIL.

")))


(defmethod tags ((self cell))
  "
Return the set of tags available for generic CELL instances.
"
  (declare (ignorable self))
  (union (call-next-method) '(:in :out :whole :top :left :bottom :right)))


(defmethod adjust-size ((self cell))
  (call-next-method)
  (setf (slot-value self 'ports)
        (let* ((bounds (bounds self))
               (left   (rect-left   bounds))
               (right  (rect-right  bounds))
               (top    (rect-top    bounds))
               (bottom (rect-bottom bounds))
               (height (rect-height bounds))
               (width  (rect-width  bounds)))
          (list* (make-instance 'port :drawable self :point (make-point :x left  :y  (truncate height 2)) :tags '(:in :out :whole :left))
                 (make-instance 'port :drawable self :point (make-point :x right :y  (truncate height 2)) :tags '(:in :out :whole :right))
                 (make-instance 'port :drawable self :point (make-point :x (truncate width 2) :y bottom)  :tags '(:in :out :whole :bottom))
                 (make-instance 'port :drawable self :point (make-point :x (truncate width 2) :y top)     :tags '(:in :out :whole :top))
                 (slot-value self 'ports))))
  self)


(defmethod select-port ((self cell) &rest tags)
  (unless (slot-value self 'ports)
    (adjust-size self))
  (flet ((find-tags (tags)
           (find-if (lambda (port) (port-tags-match-p port tags)) (ports self))))
    (let ((port (or (find-tags tags)
                    (find-tags (set-difference tags '(:in :out)))
                    (find-tags (set-difference tags '(:in :out :cdr :car)))
                    (find-tags (set-difference tags '(:in :out :cdr :car :top :left :bottom :right)))
                    (find-tags '(:whole)))))
      (unless port
        (error "Cannot find a port for ~S ~S" cell tags))
      (port-offset port (origin self)))))


;;;------------------------------------------------------------
;;; TEXT-CELL
;;;------------------------------------------------------------

(defclass text-cell (cell)
  ((text :initarg :text :initform "" :accessor cell-text)
   (align :initarg :align :initarg :alignment :initform :left :accessor align :accessor alignment)
   (line-separation :initarg :line-separation :initform 2 :accessor line-separation))
  (:documentation "
``TEXT-CELL``s are text labels without frame, possibly multi-line, and
aligned either on the left side, or right side, or centered.

Note: ``TEXT-CELL``s don't have an address.
"))


(defmethod print-object ((self text-cell) stream)
  (print-unreadable-object (self stream :identity t :type t)
    (let ((*print-circle* nil))
      (format stream "~S"
              ;; ":text ~S :align ~S :line-separation ~A"
              (list :text (cell-text self)
                    :align (align self)
                    :line-separation (line-separation self)))))
  self)

(defun text (text &key (align :left))
  (drawable (make-instance 'text-cell :text text :align align)))


(defmethod adjust-size ((self text-cell))
  (setf (slot-value self 'bounds)
        (reduce (function rect-union)
                (pile-down (mapcar (lambda (line)
                                     (bounding-box-to-rect (string-bounding-box line *font-size* *font*)))
                                   (split-sequence  #\newline (element-label (cell-text self))))
                           :align (alignment self)
                           :spacing (line-separation self))))
  (call-next-method))


(defmethod draw ((self text-cell))
  (let ((x (point-x (origin self)))
        (y (point-y (origin self))))
    (loop
       :with boxes = (mapcar (lambda (line) (bounding-box-to-rect (string-bounding-box line *font-size* *font*)))
                             (split-sequence #\newline (element-label (cell-text self))))
       :with base-line-offsets = (mapcar (compose (function -) (function rect-bottom)) boxes)
       ;; The coordinates of the boxes will be changed by pile-down.
       :for bound :in (pile-down boxes :align (alignment self) :spacing (line-separation self))
       :for line  :in (split-sequence #\newline (element-label (cell-text self)))
       :for base-line :in base-line-offsets
       :do (let ((left   (+ x (rect-left   bound)))
                 (bottom (+ y (rect-bottom bound)))
                 (width  (rect-width bound))
                 (height (rect-height bound)))
             (set-fill-color   *white*)
             (set-stroke-color *white*)
             (rectangle left bottom width height)
             (fill-and-stroke)
             (set-fill-color   *black*)
             (set-stroke-color *black*)
             (draw-string left (+ bottom base-line) line)
             (stroke))))
  self)


;;;------------------------------------------------------------
;;; DATA-CELL
;;;------------------------------------------------------------


(defclass data-cell (cell)
  ((data :initarg :data :initform "" :accessor cell-data))
  (:documentation "
``DATA-CELL``s are cells containing only the given ``DATA``, as
printed by prin1-to-string.
"))


(defmethod print-object ((self data-cell) stream)
  (print-unreadable-object (self stream :identity t :type t)
    (format stream "~S" (list :data (cell-data self))))
  self)


(defun data (data &key address)
  (drawable (make-instance 'data-cell
                :address address
                :data data)))


(defmethod tags ((self data-cell))
  "
Return the set of tags available for DATA-CELL instances.
"
  (declare (ignorable self))
  (union (call-next-method) '(:in :whole :top :left :bottom)))


(defmethod adjust-size ((self data-cell))
  (let* ((data        (if (cell-data self)
                          (princ-to-string (cell-data self))
                          " "))
         (data-width  (max (string-width data)   (string-width "-")))
         (bounds      (make-rect :size (make-size :width (+ 16 data-width) :height 16))))
    (setf (slot-value self 'bounds)
          (if (cell-address self)
              (rect-union
               (rect-offset
                (bounding-box-to-rect
                 (string-bounding-box (element-label (cell-address self)) *font-size* *font*))
                0 -12)
               bounds)
              bounds)
          (slot-value self 'ports)
          (list
           (make-instance 'port :drawable self :point (make-point :x  0 :y  8) :tags '(:in :whole :left))
           (make-instance 'port :drawable self :point (make-point :x 16 :y  0) :tags '(:in :whole :bottom))
           (make-instance 'port :drawable self :point (make-point :x 16 :y 16) :tags '(:in :whole :top)))))
  self)


(defmethod draw ((cell data-cell))
  (let ((x (point-x (origin cell)))
        (y (point-y (origin cell))))
    (when (cell-address cell)
      (draw-string x (- y 12) (element-label (cell-address cell))))
    (let* ((data     (if (cell-data cell)
                         (princ-to-string (cell-data cell))
                         " "))
           (data-width   (max (string-width data)   (string-width "-"))))

      (set-fill-color   *white*)
      (set-stroke-color *white*)
      (rectangle x y data-width 16)
      (fill-and-stroke)

      (set-fill-color   *black*)
      (set-stroke-color *black*)

      (let* ((left   (+ x  8))
             (bottom    y)
             (base   (+ y  4))
             (top    (+ y 16))
             (x      left))
        (arc x (+ bottom 8) 8 (/ pi 2) (/ pi 2/3))
        (stroke)

        (draw-string x base data) (incf x data-width)

        (move-to left bottom)
        (line-to x    bottom)
        (move-to left top)
        (line-to x    top)
        (stroke)

        (arc x (+ bottom 8) 8 (/ pi -2) (/ pi 2))
        (stroke))))
  cell)

;;;------------------------------------------------------------
;;; NSS-CELL
;;;------------------------------------------------------------

(defclass nss-cell (cell)
  ((car     :initarg :car    :initform nil :accessor cell-car)
   (cdr     :initarg :cdr    :initform nil :accessor cell-cdr)
   (sign    :initarg :sign   :initform nil :accessor cell-sign)
   (prefix  :initarg :prefix :initform nil :accessor cell-prefix)
   (tag     :initarg :tag    :initform nil :accessor cell-tag))
  (:documentation "
``NSS-CELL``s are Newell, Shaw, and Simon list cells.
"))


(defmethod print-object ((self nss-cell) stream)
  (print-unreadable-object (self stream :identity t :type t)
    (format stream "~S" (list :car (cell-car self) :cdr (cell-cdr self))))
  self)


(defun cell (car cdr &key sign prefix tag address)
  (drawable (make-instance 'nss-cell
                :address address
                :car car
                :cdr cdr
                :sign sign
                :prefix prefix
                :tag tag)))


(defmethod cell-length ((cell nss-cell))
  (loop
     :for current = cell :then (cell-cdr current)
     :count 1
     :while (typep (cell-cdr current) 'nss-cell)))


(defmethod cell-nthcdr (n (cell nss-cell))
  (loop
     :with current = cell
     :repeat (max 0 n)
     :do (setf current (cell-cdr current))
     :finally (return current)))

(defmethod cell-nth (n (cell nss-cell))
  (let ((cell (cell-nthcdr n cell)))
    (if (typep cell 'nss-cell)
        (cell-car cell)
        nil)))


(defmethod cell-last ((cell nss-cell) &optional (n 1))
  (loop
     :repeat (- (cell-length cell) n -1)
     :for current = cell :then (cell-cdr current)
     :finally (return current)))


(defun cell-label (cell)
  (if cell
      (typecase cell
        (data-cell (or (cell-address cell)
                       (princ-to-string (cell-data cell))
                       " "))
        (cell      (or (cell-address cell)
                       " "))
        (t         (princ-to-string cell)))
      " "))


(defun element-label (element)
  (if element
      (princ-to-string element)
      " "))


(defmethod tags ((self nss-cell))
  "
Return the set of tags available for NSS-CELL instances.
"
  (declare (ignorable self))
  (union (call-next-method) '(:car :cdr)))


(defmethod adjust-size ((self nss-cell))
  (let* ((sign    (element-label (cell-sign   self)))
         (prefix  (element-label (cell-prefix self)))
         (cdr     (cell-label    (cell-cdr    self)))
         (tag     (element-label (cell-tag    self)))
         (car     (cell-label    (cell-car    self)))
         (sign-width   (max (string-width sign)   (string-width "-")))
         (prefix-width (max (string-width prefix) (string-width "9")))
         (cdr-width    (max (string-width cdr)    (string-width "CXR")))
         (tag-width    (max (string-width tag)    (string-width "9")))
         (car-width    (max (string-width car)    (string-width "CXR")))
         (total-width  (+ sign-width 5 prefix-width 5 cdr-width 5 tag-width 5 car-width))
         (bounds (make-rect :size (make-size :width (+ 16 total-width) :height 16))))
    (setf (slot-value self 'bounds)
          (if (cell-address self)
              (rect-union
               (rect-offset
                (bounding-box-to-rect
                 (string-bounding-box (element-label (cell-address self)) *font-size* *font*))
                0 -12)
               bounds)
              bounds)
          (slot-value self 'ports)
          (let ((cdr-mid  (+ 8 sign-width 5 prefix-width 5 (truncate cdr-width 2)))
                (car-mid  (+ 8 sign-width 5 prefix-width 5 cdr-width 5 tag-width 5 (truncate car-width 2))))
            (list
             (make-instance 'port :drawable self :point (make-point :x 0  :y  8) :tags '(:in :whole :left))
             (make-instance 'port :drawable self :point (make-point :x 16 :y  0) :tags '(:in :whole :bottom))
             (make-instance 'port :drawable self :point (make-point :x 16 :y 16) :tags '(:in :whole :top))
             (make-instance 'port :drawable self :point (make-point :x cdr-mid :y 16) :tags '(:in  :cdr :top))
             (make-instance 'port :drawable self :point (make-point :x cdr-mid :y  0) :tags '(:out :cdr :bottom))
             (make-instance 'port :drawable self :point (make-point :x car-mid :y 16) :tags '(:in  :car :top))
             (make-instance 'port :drawable self :point (make-point :x car-mid :y  0) :tags '(:out :car :bottom))
             (make-instance 'port :drawable self :point (make-point :x (+ total-width 16) :y 8) :tags '(:out :car :right)))))))


(defmethod draw ((cell nss-cell))
  (let ((x (point-x (origin cell)))
        (y (point-y (origin cell))))
    (when (cell-address cell)
      (draw-string x (- y 12) (element-label (cell-address cell))))
    (let* ((sign    (element-label (cell-sign   cell)))
           (prefix  (element-label (cell-prefix cell)))
           (cdr     (cell-label    (cell-cdr    cell)))
           (tag     (element-label (cell-tag    cell)))
           (car     (cell-label    (cell-car    cell)))
           (sign-width   (max (string-width sign)   (string-width "-")))
           (prefix-width (max (string-width prefix) (string-width "9")))
           (cdr-width    (max (string-width cdr)    (string-width "CXR")))
           (tag-width    (max (string-width tag)    (string-width "9")))
           (car-width    (max (string-width car)    (string-width "CXR")))
           (total-width  (+ sign-width 5 prefix-width 5 cdr-width 5 tag-width 5 car-width)))

      (set-fill-color   *white*)
      (set-stroke-color *white*)
      (rectangle x y total-width 16)
      (fill-and-stroke)

      (set-fill-color   *black*)
      (set-stroke-color *black*)

      (let* ((left   (+ x  8))
             (bottom    y)
             (base   (+ y  4))
             (top    (+ y 16))
             (x      left))
        (arc x (+ bottom 8) 8 (/ pi 2) (/ pi 2/3))
        (stroke)

        (flet ((separator ()
                 (move-to (+ x 3) bottom)
                 (line-to (+ x 3) top)
                 (incf x 5)))
          (draw-string x base sign)   (incf x sign-width)   (separator)
          (draw-string x base prefix) (incf x prefix-width) (separator)
          (draw-string x base cdr)    (incf x cdr-width)    (separator)
          (draw-string x base tag)    (incf x tag-width)    (separator)
          (draw-string x base car)    (incf x car-width)

          (move-to left bottom)
          (line-to x    bottom)
          (move-to left top)
          (line-to x    top)
          (stroke))

        (arc x (+ bottom 8) 8 (/ pi -2) (/ pi 2))
        (stroke))))
  cell)


;;;------------------------------------------------------------
;;; ARROW
;;;------------------------------------------------------------

(defclass arrow ()
  ((origin :initarg :origin :initform nil    :accessor arrow-origin)
   (target :initarg :target :initform nil    :accessor arrow-target)
   (style  :initarg :style  :initform :solid :accessor arrow-style)
   (labels :initarg :labels :initform '()    :accessor arrow-labels)
   (points :initarg :points :initform '()    :accessor arrow-points))
  (:documentation "

``ARROW``s are lines or polylines drawn from a ``PORT`` to another,
with a tip drawn at the target.

"))

(defmethod print-object ((self arrow) stream)
  (print-unreadable-object (self stream :identity t :type t)
    (format stream "~S" (list :origin (arrow-origin self)
                              :target (arrow-target self)
                              :style  (arrow-style  self)
                              :labels (arrow-labels self)
                              :points (arrow-points self))))
  self)

(defun crooked-arrow (origin target points &key source-label target-label (style :solid))
  (drawable (make-instance 'arrow
                :origin origin
                :target target
                :style  style
                :labels (append (when source-label (list :origin source-label))
                                (when target-label (list :target target-label)))
                :points points)))

(defun arrow (origin target &key source-label target-label (style :solid))
  (drawable (make-instance 'arrow
                :origin origin
                :target target
                :style  style
                :labels (append (when source-label (list :origin source-label))
                                (when target-label (list :target target-label)))
                :points (list (port-point origin) (port-point target)))))


(defmethod find-arrow ((origin port) (target port) &key tags)
  (declare (ignore tags))
  (find-if (lambda (object)
             (and (typep object 'arrow)
                  (eql origin (arrow-origin object))
                  (eql target (arrow-target object))))
           *draw-list*))

(defmethod find-arrow ((origin drawable) (target drawable) &key tags)
  (declare (ignore tags))
  (find-if (lambda (object)
             (and (typep object 'arrow)
                  (eql origin (port-drawable (arrow-origin object)))
                  (eql target (port-drawable (arrow-target object)))
                  (or (endp tags)
                      (port-tags-match-p (arrow-origin object) tags))))
           *draw-list*))

(defun arrow-add-stems (arrow &key (length 6) (direction :horizontal))
  (setf (arrow-points arrow)
        (let* ((points (arrow-points arrow))
               (p1     (first points))
               (pn     (first (last points)))
               (offset (make-point (ecase direction
                                     (:horizontal :x)
                                     (:vertical   :y)) length)))
          (append (list p1 (vector+ p1 offset))
                  (butlast (rest points))
                  (list (if (eql direction :horizontal)
                            (vector- pn offset)
                            (vector+ pn offset))
                        pn)))))


(defmethod draw ((self arrow))
  ;; TODO: for dotted arrows, we'd want to ensure drawing the vertices
  ;; and the source and target too.
  (case (arrow-style self)
    (:dotted   (set-dash-pattern #(6 6) 3))
    (otherwise (set-dash-pattern #() 0)))
  (let ((pt (first (arrow-points self))))
    (move-to (point-x pt) (point-y pt)))
  (loop
     :for pt :in (rest (arrow-points self))
     :for before-last = (first (arrow-points self)) :then last
     :for last = pt
     :do (line-to (point-x pt) (point-y pt))
     :finally (let* ((src before-last)
                     (dst last)
                     (unit  (unit-vector (vector- dst src)))
                     (left  (vector+ dst (vector* -7 (vector-rotate unit (/ pi -8)))))
                     (right (vector+ dst (vector* -7 (vector-rotate unit (/ pi +8))))))
                (stroke) ; seems the dash-pattern is enacted only on stroke.
                (set-line-join :miter)
                (set-dash-pattern #() 0)
                (move-to (point-x left)  (point-y left))
                (line-to (point-x dst)   (point-y dst))
                (line-to (point-x right) (point-y right))
                (stroke)))
  self)



;;;------------------------------------------------------------
;;;
;;;------------------------------------------------------------


(defgeneric map-cells (fun cell)
  (:method (fun (other t))
    (declare (ignorable fun other))
    other)

  (:method (fun (cell cell))
    (funcall fun cell))

  (:method (fun (cell nss-cell))
    (funcall fun cell)
    (map-cells fun (cell-car cell))
    (map-cells fun (cell-cdr cell))))


(defun place-list-vertically (nss-list &key (vertical-offset 20) (horizontal-offset 50))
  (loop
     :for current = nss-list :then next
     :for next    = (and (typep current 'nss-cell) (cell-cdr current))
     :while (and next (typep next 'cell))
     :do (progn
           (place next (below current vertical-offset))
           (when (and (typep (cell-car current) 'cell)
                      (logbitp 1 (cell-prefix current)))
             (place (cell-car current) (right-of current horizontal-offset))))))


(defun make-car-cdr-arrows (root)
  (map-cells (lambda (cell)
               (when (typep cell 'nss-cell)
                 (when (typep (cell-cdr cell) 'cell)
                   (unless (find-arrow  cell (cell-cdr cell) :tags '(:cdr :bottom))
                     (arrow (select-port cell            :cdr :bottom)
                            (select-port (cell-cdr cell) :cdr :top))))
                 (when (typep (cell-car cell) 'cell)
                   (unless (find-arrow  cell (cell-car cell) :tags '(:car :right))
                     (arrow (select-port cell            :car :right)
                            (select-port (cell-car cell) :whole :left)
                            :style (if (logbitp 1 (cell-prefix cell))
                                       :solid
                                       :dotted))))))
             root))




;; (mapcar (lambda (angle) (vector-rotate (make-point :x 10 :y 0) angle))
;;         (list 0 (/ pi 4) (/ pi 2) pi (/ pi 2/3)))




(defun xvv (pathname)
  (ext:shell (format nil "emacsclient -n ~S" pathname))
  ;;(ext:shell (format nil "xv -windowid $(xwininfo -int  2> /dev/null |awk '/Window id/{print $4}') -maxpect -smooth ~A" (namestring pathname)))
  )


(defun draw-figure-3 (width height)
  (let* ((*draw-list* '())
         (nu.x (data "x-COMP OF NU" :address "δ11"))
         (nu.y (data "y-COMP OF NU" :address "δ21"))
         (a.x  (data "x-COMP OF A"  :address "α11"))
         (a.y  (data "y-COMP OF A"  :address "α21"))
         (one  (data "1.0"          :address "α31"))
         (nu   (cell nu.x
                     (cell nu.y
                           (cell one
                                 (cell "NU" 0 :address "δ4" :prefix 0)
                                 :address "δ3" :prefix 0)
                           :address "δ2" :prefix 2)
                     :address "δ1" :prefix 2))
         (a    (cell a.x
                     (cell a.y
                           (cell one
                                 (cell "A" 0 :address "α4" :prefix 0)
                                 :address "α3" :prefix 2)
                           :address "α2" :prefix 2)
                     :address "α1" :prefix 2))
         (lpts (cell nu
                     (cell a
                           (text "TO POINT
B ENTRY")
                           :address "α" :prefix 3)
                     :address "δ" :prefix 3))
         (lpts-label (text "LPTS"))
         (horiz 40)
         (verti 25))

    (adjust-size lpts-label)
    (map-cells 'adjust-size lpts)

    (place lpts-label (make-point :x 10 :y (- height verti)))
    (place lpts  (right-of lpts-label horiz))
    (place nu    (right-of lpts       horiz))
    (place-list-vertically nu :vertical-offset verti :horizontal-offset horiz)
    (place a   (below (cell-last nu) verti))
    (place (cell-cdr lpts) (left-of a (+ horiz (rect-width (bounds a))))) ;; ***
    (place-list-vertically a :vertical-offset verti :horizontal-offset horiz)
    (place (cell-cdr (cell-cdr lpts)) (below  (cell-cdr lpts) verti))

    (arrow (select-port lpts-label :whole :right)
           (select-port lpts       :whole :left))
    (make-car-cdr-arrows lpts)

    (arrow-add-stems (find-arrow (cell-nthcdr 2 (cell-car lpts))
                                 (cell-nth    2 (cell-car lpts))))


    (draw-objects)))



(defun figure-3 ()
  (let ((page (page :width (cm 17.0) :height (cm 11.0) :density (dpi 300))))
    (with-page (page :unit :pt)
      (let ((width       (inch-to-pt (size-width  (page-size-inch page))))
            (height      (inch-to-pt (size-height (page-size-inch page))))
            (*font*      (get-font "truetype/verdana.ttf"))
            (*font-size* 12.0))

        (set-fill-color *white*)
        (rectangle 0 0 width height)
        (fill-and-stroke)

        (set-font *font* *font-size*)
        (set-fill-color   *black*)
        (set-stroke-color *black*)

        (draw-figure-3 width height)

        (save-png "figure-3.png")
        :done))))



(defun draw-figure-2 (width height)
  (let* ((*draw-list* '())
         (a.x  (data "x-COMP OF A"  :address "α11"))
         (a.y  (data "y-COMP OF A"  :address "α21"))
         (b.x  (data "x-COMP OF B"  :address "β11"))
         (b.y  (data "y-COMP OF B"  :address "β21"))
         (c.x  (data "x-COMP OF C"  :address "γ11"))
         (c.y  (data "y-COMP OF C"  :address "γ21"))
         (one  (data "1.0"          :address "α31"))

         (a    (cell a.x
                     (cell a.y
                           (cell one
                                 (cell "A" 0 :address "α4" :prefix 0)
                                 :address "α3" :prefix 2)
                           :address "α2" :prefix 2)
                     :address "α1" :prefix 2))
         (b    (cell b.x
                     (cell b.y
                           (cell one
                                 (cell "B" 0 :address "β4" :prefix 0)
                                 :address "β3" :prefix 0)
                           :address "β2" :prefix 2)
                     :address "β1" :prefix 2))
         (c    (cell c.x
                     (cell c.y
                           (cell one
                                 (cell "C" 0 :address "γ4" :prefix 0)
                                 :address "γ3" :prefix 0)
                           :address "γ2" :prefix 2)
                     :address "γ1" :prefix 2))
         (lpts (cell a
                     (cell b
                           (cell c
                                 0
                                 :address "γ" :prefix 3)
                           :address "β" :prefix 3)
                     :address "α" :prefix 3))
         (lpts-label (text "LPTS"))

         (ab.length (data "Length of Seg AB" :address "μ31"))
         (ac (cell a
                   (cell c
                         (text "TO DESCRIPTION
LIST FOR SEGMENT AC")
                         :address "ν2"
                         :prefix 1)
                   :address "ν1"
                   :prefix 1))
         (ab (cell a
                   (cell b
                         (cell ab.length
                               (cell ac
                                     (cell ac
                                           (cell (text "TO TRIANGLE
ABC LISTED
ON LTRNGL")
                                                 0
                                                 :address "μ6"
                                                 :prefix 1
                                                 :tag 6)
                                           :address "μ5"
                                           :prefix 1
                                           :tag 4)
                                     :address "μ4"
                                     :prefix 1
                                     :tag 1)
                               :address "μ3"
                               :prefix 2)
                         :address "μ2"
                         :prefix 1)
                   :address "μ1"
                   :prefix 1))
         (lseg (cell ab
                     (cell ac
                           (text "TO NEXT
SEGMENT
ON LSEG")
                           :address "ν"
                           :prefix 3)
                     :address "μ"
                     :prefix 3))
         (lseg-label         (text "LSEG"))
         (to-point-a-label-1 (text "TO POINT A"))
         (to-point-a-label-2 (text "TO POINT A"))
         (to-point-b-label   (text "TO POINT B"))
         (to-point-c-label   (text "TO POINT C"))
         (to-seg-ac-label    (text "To Seg AC"))
         (point-a-label      (text "POINT A"))
         (segment-ab-label   (text "SEGMENT AB"))
         (to-1.0-label       (text "TO CONSTANT 1.0"))
         (horiz 30)
         (verti 20))

    (map nil (function adjust-size)
         (list lpts-label lseg-label
               to-1.0-label
               to-point-a-label-1 to-point-a-label-2
               to-point-b-label to-point-c-label
               to-seg-ac-label point-a-label segment-ab-label))
    (map-cells 'adjust-size lpts)
    (map-cells 'adjust-size lseg)

    (place lpts-label (make-point :x 10 :y (- height 80)))
    (place lpts  (below (right-of lpts-label (truncate horiz 2)) 8))
    (place a (right-of lpts horiz))
    (place-list-vertically a :vertical-offset verti :horizontal-offset horiz)
    (place b   (below (cell-last a) verti))
    (place-list-vertically b :vertical-offset verti :horizontal-offset horiz)
    (place (cell-cdr lpts) (left-of b (+ horiz (rect-width (bounds (cell-cdr lpts))))))
    (place c   (below (cell-last b) verti))
    (place-list-vertically c :vertical-offset verti :horizontal-offset horiz)
    (place (cell-cdr (cell-cdr lpts)) (left-of c (+ horiz (rect-width (bounds (cell-cdr (cell-cdr lpts)))))))

    (place lseg (right-of a.x horiz))
    (place lseg-label (above (left-of lseg (truncate horiz 2)) verti))
    (place ab   (right-of lseg horiz))
    (place-list-vertically ab :vertical-offset verti :horizontal-offset horiz)
    (place ac   (below (cell-last ab) verti))
    ;; (place-list-vertically ac :vertical-offset verti :horizontal-offset horiz)
    (place (cell-cdr ac) (below ac (* 2 verti)))
    (place (cell-last ac) (below (cell-last ac 2) verti))
    (place (cell-car (cell-last ab)) (right-of (cell-last ab) horiz))

    (place (cell-cdr lseg) (left-of ac (+ horiz (rect-width (bounds (cell-cdr lseg))))))
    (place (cell-cdr (cell-cdr lseg)) (below (cell-cdr lseg)))

    (place point-a-label      (above (left-of  a   10) 20))
    (place segment-ab-label   (above (left-of  ab  10) 20))
    (place to-point-a-label-1 (above (right-of ab -20) 20))
    (place to-point-b-label   (below (right-of (cell-cdr ab) -20) 10))
    (place to-point-a-label-2 (above (right-of ac -55) 30))
    (place to-point-c-label   (below (right-of (cell-cdr ac) -20) 20))
    (place to-1.0-label (right-of (cell-cdr (cell-cdr c)) 10))

    (place (cell-last (cell-car lseg)) (below  (cell-last (cell-car lseg) 2)))

    (place (cell-nthcdr 2 lseg)
           (below (left-of (cell-nthcdr 1 lseg) -15) 60))

    (place (cell-nthcdr 2 (cell-nth 1 lseg))
           (below  (cell-cdr (cell-nth 1 lseg)) 40))

    (place to-seg-ac-label (below (right-of (cell-nthcdr 3 (cell-car lseg))) 10))

    (place (cell-car (cell-last (cell-car lseg)))
           (right-of (cell-last (cell-car lseg)) 60))

    (arrow (select-port lpts-label :whole :right)
           (select-port lpts       :whole :left))

    (arrow (select-port lseg-label :whole :right)
           (select-port lseg       :whole :left))

    (make-car-cdr-arrows lpts)
    (make-car-cdr-arrows lseg)

    ;; SEGMENT AB - TO POINT A
    (let* ((src   (cell-nth 0 lseg))
           (dst   (cell-car lpts))
           (ori   (select-port src :car :top))
           (tar   (select-port dst :cdr :top))
           (arrow (find-arrow src dst)))
      (remove-draw-object arrow)
      (crooked-arrow ori tar
                     (list
                      (port-point ori)
                      (vector+ (port-point ori) (make-point :y 20))
                      (vector+ (port-point tar) (make-point :y 20))
                      (port-point tar))
                     :style :dotted))

    ;; SEGMENT AB - TO POINT B
    (let* ((src   (cell-cdr (cell-car lseg)))
           (dst   (cell-nth 1 lpts))
           (ori   (select-port src :car :bottom))
           (tar   (select-port dst :car :top))
           (below (vector- (port-point ori) (make-point :y 10)))
           (above (vector+ (port-point tar) (make-point :y 10)))
           (arrow (find-arrow src dst)))
      (remove-draw-object arrow)
      (crooked-arrow ori tar
                     (list
                      (port-point ori)
                      below
                      (make-point :x (point-x (left-of lseg 0))
                                  :y (point-y below))
                      (make-point :x (point-x (left-of lseg 0))
                                  :y (point-y above))
                      above
                      (port-point tar))
                     :style :dotted))

    ;; SEGMENT AC - TO POINT A
    (let* ((src   (cell-nth 1 lseg))
           (dst   (cell-car lpts))
           (ori   (select-port src :car :top))
           (tar   (select-port dst :car :top))
           (arrow (find-arrow src dst))
           (above-ori   (vector+ (port-point ori) (make-point :y 10)))
           (left-corner (left-of (cell-cdr lseg) 20)))
      (remove-draw-object arrow)
      (crooked-arrow ori tar
                     (list
                      (port-point ori)
                      above-ori
                      (make-point :x (point-x left-corner)
                                  :y (point-y above-ori))
                      (make-point :x (point-x left-corner)
                                  :y (+ (point-y (port-point tar)) 12))
                      (vector+ (port-point tar) (make-point :y 12))
                      (port-point tar))
                     :style :dotted))

    ;; SEGMENT AC - TO POINT C
    (let* ((src   (cell-cdr (cell-nth 1 lseg)))
           (dst   (cell-nth 2 lpts))
           (ori   (select-port src :car :bottom))
           (tar   (select-port dst :car :top))
           (arrow (find-arrow src dst)))
      (remove-draw-object arrow)
      (crooked-arrow ori tar
                     (list
                      (port-point ori)
                      (below (port-point ori) 5)
                      (right-of (above (port-point tar) 5) 20)
                      (port-point tar))
                     :style :dotted))

    ;; to AC
    (let* ((src   (cell-nthcdr 3 (cell-car lseg)))
           (dst   (cell-nth 1 lseg))
           (ori   (select-port src :car :right))
           (tar   (select-port dst :car :right))
           (arrow (find-arrow src dst)))
      (setf (arrow-points arrow)
            (list (port-point ori)
                  (right-of (port-point ori) 20)
                  (above (right-of (port-point tar) 20) 10)
                  (port-point tar))))
    ;; to AC
    (let* ((src   (cell-nthcdr 4 (cell-car lseg)))
           (dst   (cell-nth 1 lseg))
           (ori   (select-port src :car :right))
           (tar   (select-port dst :car :right))
           (arrow (find-arrow src dst)))
      (setf (arrow-points arrow)
            (list (port-point ori)
                  (right-of (port-point ori) 10)
                  (above (right-of (port-point tar) 10) 10)
                  (port-point tar))))

    ;; - TO CONSTANT 1.0
    (dolist (cell (list (cell-nth 1 lpts)
                        (cell-nth 2 lpts)))
      (arrow-add-stems (find-arrow (cell-nthcdr 2 cell)
                                   (cell-nth    2 cell))
                       :length 12))

    (draw-objects)))


(defun figure-2 ()
  (let ((page (page :width (cm 27.7) :height (cm 19.0) :density (dpi 300))))
    (with-page (page :unit :pt)
      (let ((width       (inch-to-pt (size-width  (page-size-inch page))))
            (height      (inch-to-pt (size-height (page-size-inch page))))
            (*font*      (get-font "truetype/verdana.ttf"))
            (*font-size* 10.0))

        (set-fill-color *white*)
        (rectangle 0 0 width height)
        (fill-and-stroke)

        (set-font *font* *font-size*)
        (set-fill-color   *black*)
        (set-stroke-color *black*)

        (draw-figure-2 width height)

        (let* ((*draw-list* '())
               (*old-draw-list* '())
               (triangle  (triangle :a (make-point :x 0   :y 0)  :label-a "A"
                                    :b (make-point :x 0   :y 80) :label-b "B"
                                    :c (make-point :x 120 :y 0)  :label-c "C")))
          (place triangle (make-point :x 450 :y 40))
          (place (text "GRAPHIC REPRESENTATION
OF DIAGRAM" :align :center) (above (right-of triangle -20) 40))
          (draw-objects))

        (save-png "figure-2.png")
        :done))))



(defmacro drawing (&body body)
  `(let ((page (page :width (cm 25.7) :height (cm 17.0) :density (dpi 72))))
     (with-page (page :unit :pt)
       (let ((width       (inch-to-pt (size-width  (page-size-inch page))))
             (height      (inch-to-pt (size-height (page-size-inch page))))
             (*font*      (get-font "truetype/verdana.ttf"))
             (*font-size* 12.0))

         (set-fill-color *white*)
         (rectangle 0 0 width height)
         (fill-and-stroke)

         (set-font *font* *font-size*)
         (set-fill-color   *black*)
         (set-stroke-color *black*)

         (progn ,@body)

         (time (save-png "example.png"))
         (print :done)))
     (xvv "example.png")))


#-(and)
(drawing
 (let ((*draw-list* '())
       (r (make-rect :origin (make-point :x 100 :y 10)
                     :size (make-size :width 100 :height 20)))
       (s (make-rect :origin (make-point :x 0 :y 10)
                     :size (make-size :width 200 :height 50)))
       (u (make-rect :origin (make-point :x 10 :y 10)
                     :size (make-size :width 500 :height 30))))
   (appendf *draw-list* (list r s u))
   (stack-up (list r s u) :align :center)
   (draw-objects)))


#-(and)
(drawing
 (let* ((*draw-list* '())
        (text (text "Hello
World!
How do you do?" :align :left)))
   (adjust-size text)
   (place text (make-point :x 100 :y 250))
   (draw-objects)))



;;;; THE END ;;;;
ViewGit