;;;; -*- mode:lisp;coding:utf-8 -*- ;;;;************************************************************************** ;;;;FILE: figures.lisp ;;;;LANGUAGE: Common-Lisp ;;;;SYSTEM: Common-Lisp ;;;;USER-INTERFACE: NONE ;;;;DESCRIPTION ;;;; ;;;; Figures. Draws NSS structures with vecto. ;;;; ;;;;AUTHORS ;;;; Pascal J. Bourguignon ;;;;MODIFICATIONS ;;;; 2011-01-19 Completed. ;;;;BUGS ;;;;LEGAL ;;;; GPL ;;;; ;;;; Copyright Pascal J. Bourguignon 2011 - 2011 ;;;; ;;;; 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 ;;;;************************************************************************** (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 ;;;;