;;;;; 2005-05-24 Trying again. I start this after abandoning an elaborate
;;;;;                          attempt to do a magnificently generic 
;;;;;                          draw-anything program, which collapsed under
;;;;;                          its own weight after three days' labor. Now
;;;;;                          I revert to an earlier starting point --
;;;;;                          namely the plot.lisp program I used for the 
;;;;;                          "Life Cycles" column -- and I'll try to
;;;;;                          salvage some good ideas from the recent fiasco.
;;;;;
;;;;; 2005-05-25 Update.       I didn't even finish before making a further
;;;;;                          major revision, putting all the action into a
;;;;;                          set of local procs.
;;;;; 
;;;;; 2005-05-26 Update.       And that idea lasted less than a day. I'm back
;;;;;                          to Plan B.
;;;;; 
;;;;; 2005-05-30               I have something that works, and I'm going to clean
;;;;;                          up just a little, add some documentation, and then
;;;;;                          leave it for a while. 
;;;;;                          
;;;;;                          Still to come, someday: bar charts and histograms.
;;;;;                          Error bars. 3D. Plotting in the complex plane.
;;;;;                          Arrowhead glyphs.
;;;;;
;;;;; 2009-04-14               Updated for CCL. Replaced the save-file dialog in lips
;;;;;                          with a call to a Cocoa routine.
;;;;;                          
;;;;; 2010-03-13               Minor tidying up in preparation for posting on
;;;;;                          bit-player.


;;;;; COMPATIBILITY NOTE:
;;;;; As far as I know, everything in this file with one small exception is standard
;;;;; Common Lisp and should compile with any version of that language. The exception
;;;;; is this function call, near the start of the lips procedure:
;;;;; 
;;;;;     (gui::cocoa-choose-new-file-dialog)
;;;;; 
;;;;; In Clozure Common Lisp (see clozure.com) this call opens a Save File dialogue.
;;;;; Common Lisp has no portable method of invoking such user-interface actions, but
;;;;; most lisps include some variation. The syntax could be a little different.




;;;;;;;;;;;;;;;;;;;;;;;         PLOT.LISP           ;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;    GUIDE TO ARGUMENTS       ;;;;;;;;;;;;;;;;;;;;;;;;;;;

 ;  data                                     (required) list of drawing commands, see below

 ;  :filename nil                            will prompt if nil

 ;  :x-min nil                               if none specified, will
 ;  :x-max nil                               use extrema of data
 ;  :y-min nil
 ;  :y-max nil

 ;  :width 400                               dimensions of content area in PS points
 ;  :height 250

 ;  :transform-x-fn #'identity               e.g., #'(lambda (x) (log x 10))
 ;  :transform-y-fn #'identity

 ;  :line-thickness 1.0                      defaults to be overridden by the
 ;  :line-color cmyk:red                     various set... commands
 ;  :dot-diameter 2.0

 ;  :bkgd-color cmyk:putty                   default is a beige box with white gridlines
 ;  :grid-color cmyk:white
 ;  :grid-thickness 0.75

 ;  :grids-latitudinal nil                   arg should be a number k, meaning a gridline
 ;  :grids-longitudinal nil                  every k units, or a list of values

 ;  :frame-bottom t                          thin black lines along left & bottom edges
 ;  :frame-left t

 ;  :tick-color cmyk:black                   format of tickmarks
 ;  :tick-thickness 0.75
 ;  :tick-length -4                          neg = "outside"

 ;  :ticks-bottom nil                        arguments as for gridlines
 ;  :ticks-left nil

 ;  :tick-labels-bottom t                    "t" means label every tick with its x or y 
 ;  :tick-labels-bottom-format-string "~S"   value, as appropriate. Can also supply a
 ;  :tick-labels-bottom-x-adj 0.0            list of values, one for each tick. Format
 ;  :tick-labels-bottom-y-adj -0.5           strings, e.g., "~:D" puts commas in decimal
 ;  :tick-labels-left t                      numbers. The default adjustments are fudge
 ;  :tick-labels-left-format-string "~S"     factors that work for Helvetica 8.
 ;  :tick-labels-left-x-adj 1.4
 ;  :tick-labels-left-y-adj -1.0

 ;  :axis-label-bottom nil                   
 ;  :axis-label-left nil
 ;  :label-font-name "Helvetica"
 ;  :label-font-size 8

 ;  :debug nil                               if t, prints commands to listener, not lips




;;;;;;;;;;;;;;;;;;;;;;;         PLOT.LISP           ;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;  GUIDE TO DRAWING COMMANDS  ;;;;;;;;;;;;;;;;;;;;;;;;;;;

; (plotline (x . y) (u . v) ... )    -- line graph

; (plotarea (x . y) (u . v) ... )    -- area graph, or filled line graph

; (plotdots (x . y) (u . v) ... )

; (setdotdiameter d)

; (plotvector (x . y) mag theta)     -- note, just one point, theta in degrees
;                                       with 0 degrees pointing to +x

; (plotvector-abs (x . y) mag theta) -- just like plotvector, but mag is
;                                       unscaled, taken as distance in points

; (plotpolygon (x . y) (u . v) ...)  -- automatically closes the path between
;                                       first pt and last pt. NOTE: must follow
;                                       with stroke or fill

; (plotrectangle (x . y) (u . v))    -- lower left and upper right. NOTE: must follow
;                                       with stroke or fill

; (plotglyphs ((x . y) (u . v))      -- note 1 pt or a list of pts but not multiple pts
;             :glyph 'tee            -- name of predefined glyph in a-list, default = 'square
;             :scale-x 5             -- in absolute points, default = 1
;             :scale-y 2             -- in absolute points, default = 1
;             :rotate 90             -- in degrees from +x axis, positive ccw, default = 0
;             :render 'fill)         -- should be 'fill or 'stroke or 'stroke-fill,
;                                       default = 'fill

; (defineglyph name cmds)            -- name is a symbol, cmds a list of drawing
;                                       commands 

; (plotlabel (x . y) "string" align) -- one point. align = 'left or 'center or 'right

; All other commands are passed on to LIPS without error checking of any kind. Also
; without scaling or transforming.





;;;;;;;;;;;;;;;;;;;;;;; GUIDE TO POINT FORMATS ;;;;;;;;;;;;;;;;;;;;;;;;;

; Geometric points in drawing commands can take various forms. Here are a
; few examples of arguments to plotline that should all work. For more
; detail see "CANONICAL FORM OF POINTS," toward the bottom of this file.


; (plotline (x . y) (u . v) ... )
; (plotline ((x . y) (u . v) ... ))
; (plotline (x y) (u v) ... ) 
; (plotline ((x y) (u v) ... ))
; (plotline (make-pt :x x :y y :x-scale t :y-scale t) ... )
; (plotline #((x . y) (u . v) ... ))
; (plotline (#(x y) #(u v) ... ))

; Also note this shortcut:
; (plotline (x y z u v w ... )
;     becomes (plotline (0 . x) (1 . y) (2 . z) ... )






;; ASSUMPTIONS AND DEPENDENCIES
;; 
;; We require 'lips.lisp' for Postscript output and 'colornames.lisp' for
;; shorthand terms for cmyk, rgb and hsb colors. The file 'predicates.lisp'
;; provides two small utilities, 'properlistp' and 'sequencep'. Similarly,
;; 'bph-utilities' supplies 'round-k' and 'iota'. Also flatten.lisp.
;;
;; Note 2009-04-14. All dependent files are now textually included here.
;;
;; Note 2010-03-13. Also added defmacro for nlet, from my init.lisp file







;;;;;;;;;;;;;;;;;;;;;;; MISCELLANEOUS ROUTINES ;;;;;;;;;;;;;;;;;;;;;;;;;



;; Syntax for the Scheme-style named let
;;
;;
;; This is supposed to transform 
;;
;; (defun factn (n)
;;   (nlet loop ((n n) (prod 1))
;;     (if (<= n 1)
;;         prod
;;         (loop (1- n) (* n prod)))))
;;
;; into
;;
;; (defun factn (n)
;;   (labels ((loop (n prod)
;;              (if (<= n 2)
;;                  prod
;;                  (loop (1- n) (* n prod)))))
;;     (prod n 1)))

(defmacro nlet (name argbinds &rest body-exprs)
  `(labels ((,name ,(mapcar #'car argbinds)
                   ,@body-exprs))
     (,name ,@(mapcar #'cadr argbinds))))



;; iota creates a list of numbers starting with lo and continuing with
;; lo+delta and further increments of delta until the value exceeds hi.
;; 
;; E.g., (iota 3 9 2) --> (3  5  7  9)
;; If all arguments are integers or rationals, so will the members of
;; the output list. If either lo or delta is a float, the elements will
;; also be floats.
;;
;; Note this is strictly a counting *up* process. The only way to get a
;; count down is to reverse the result.

(defun iota (lo hi delta)
  
  "count from lo to hi in increments of delta"
  
  (nlet loop ((iota-list nil) (sum lo))
    (if (> sum hi)
      (nreverse iota-list)
      (loop (cons sum iota-list)
            (+ sum delta)))))

(defun degrees-to-radians (theta)
  (* (/ pi 180) theta))


(defun radians-to-degrees (theta)
  (* (/ 180 pi) theta))



;; You learn something every day. The standard predicate listp
;; fails to distinguish between proper lists and dotted
;; ones. How could I have missed this for all these years?

(defun properlistp (thing)
  
  "t for proper lists but not dotted ones"
  
  (if (null thing)
    t
    (if (consp thing)
      (properlistp (cdr thing))
      nil)))

;; a predicate to recognize proper lists and vectors but not
;; strings (which vectorp counts as vectors). Note that the
;; empty sequence -- nil, '(), #() -- is accepted.
      
(defun sequencep (thing)

  "t for a proper list or a vector but nil a string"

  (and (or (properlistp thing)
           (vectorp thing))
       (not (stringp thing))))


(defun flatten (tree)
  (cond ((null tree) nil)
        ((atom tree) (list tree))
        ((atom (car tree))
         (cons (car tree) (flatten (cdr tree))))
        (t (append (flatten (car tree))
                   (flatten (cdr tree))))))


;;; Returns the value of n rounded to k
;;; decimal places. Always returns a float.

(defun round-k (n k)
  
  "Round n to k decimal places and return float value."
  
  (let ((factor (expt 10 k)))
    (float (/ (round (* n factor)) factor))))







;;;;;;;;;;;;;;;;;;;;;;;      COLORS     ;;;;;;;;;;;;;;;;;;;;;;;;;



;; Predicates for recognizing structures that might designate a color.

(defun cmyk-p (thing)
  (and (listp thing)
       (= (length thing) 4)
       (every #'(lambda (x)
                  (and (numberp x)
                       (>= x 0.0)
                       (<= x 1.0)))
              thing)))

;; Note that rgb-p and hsb-p are in fact identical. At the moment there's
;; no way to distinguish them extensionally.

(defun rgb-p (thing)
  (and (listp thing)
       (= (length thing) 3)
       (every #'(lambda (x)
                  (and (numberp x)
                       (>= x 0.0)
                       (<= x 1.0)))
              thing)))

(defun hsb-p (thing)
  (and (listp thing)
       (= (length thing) 3)
       (every #'(lambda (x)
                  (and (numberp x)
                       (>= x 0.0)
                       (<= x 1.0)))
              thing)))

(defpackage "CMYK-COLORNAMES"
  (:nicknames "CMYK")
  (:use "COMMON-LISP")
  (:export black white red green blue cyan magenta yellow orange purple putty
           grass cerulean seablue midnight pale-blue burgundy
           butter margarine frenchbleu brown-bag forrest))

(in-package "CMYK")

(defparameter black        '(0.00 0.00 0.00 1.00))
(defparameter white        '(0.00 0.00 0.00 0.00))
(defparameter red          '(0.00 1.00 1.00 0.00))
(defparameter green        '(1.00 0.00 1.00 0.00))
(defparameter blue         '(1.00 1.00 0.00 0.00))
(defparameter cyan         '(1.00 0.00 0.00 0.00))
(defparameter magenta      '(0.00 1.00 0.00 0.00))
(defparameter yellow       '(0.00 0.00 1.00 0.00))
(defparameter orange       '(0.00 0.25 0.65 0.00))
(defparameter purple       '(0.36 0.54 0.00 0.00))
(defparameter putty        '(0.05 0.06 0.10 0.04))  ; revised 2005-05-01
(defparameter grass        '(0.40 0.00 0.55 0.00))
(defparameter cerulean     '(0.85 0.00 0.05 0.00))
(defparameter seablue      '(0.85 0.60 0.00 0.00))
(defparameter midnight     '(1.00 0.80 0.00 0.00))
(defparameter pale-blue    '(0.10 0.05 0.00 0.00))
(defparameter burgundy     '(0.30 0.70 0.50 0.00))
(defparameter butter       '(0.00 0.05 0.35 0.00))
(defparameter margarine    '(0.02 0.00 0.76 0.00))
(defparameter frenchbleu   '(0.30 0.20 0.00 0.00))
(defparameter brown-bag    '(0.17 0.23 0.43 0.00))
(defparameter forrest      '(1.00 0.26 1.00 0.56))



(defpackage "RGB-COLORNAMES"
  (:nicknames "RGB")
  (:use "COMMON-LISP")
  (:export black white red green blue cyan magenta yellow putty))

(in-package "RGB")

(defparameter black        '(0.00 0.00 0.00))
(defparameter white        '(1.00 1.00 1.00))
(defparameter red          '(1.00 0.00 0.00))
(defparameter green        '(0.00 1.00 0.00))
(defparameter blue         '(0.00 0.00 1.00))
(defparameter cyan         '(0.00 0.65 0.84))
(defparameter magenta      '(0.84 0.00 0.43))
(defparameter yellow       '(0.96 0.90 0.09))
(defparameter putty        '(0.91 0.90 0.86))



(defpackage "HSB-COLORNAMES"
  (:nicknames "HSB")
  (:use "COMMON-LISP")
  (:export black white red green blue cyan magenta yellow putty))

(in-package "HSB")

(defparameter black        '(0.00 0.00 0.00))
(defparameter white        '(1.00 1.00 1.00))
(defparameter red          '(1.00 0.00 0.00))
(defparameter green        '(1.00 1.00 0.00))
(defparameter blue         '(0.00 0.00 1.00))
(defparameter cyan         '(0.54 1.00 0.84))
(defparameter magenta      '(0.91 1.00 0.84))
(defparameter yellow       '(0.16 0.91 0.96))
(defparameter putty        '(0.13 0.05 0.91))



(defpackage "GREY-COLORNAMES"
  (:nicknames "GREY")
  (:use "COMMON-LISP")
  (:export black white mid-grey))

(in-package "GREY-COLORNAMES")

(defparameter black        '(1.00))
(defparameter white        '(0.00))
(defparameter mid-grey     '(0.50))

(in-package "COMMON-LISP-USER")





;;;;;;;;;;;;;;;;;;;;;;;      CONSTANTS      ;;;;;;;;;;;;;;;;;;;;;;;;;
;; handy to have when dealing with Postscript programs.

(defconstant buttcap 0)
(defconstant roundcap 1)
(defconstant squarecap 2)

(defconstant miterjoin 0)
(defconstant roundjoin 1)
(defconstant beveljoin 2)




;;;;;;;;;;;;;;;;;;;;;;;       A DATA STRUCTURE         ;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;      FOR GEOMETRIC POINTS      ;;;;;;;;;;;;;;;;;;;;;;;;;

;;; I want to be able to accept several representations of geometric
;;; points in two dimensions -- a dotted pair (x . y), a two-element
;;; list (x y), the corresponding vector #(x y). I also have a defined
;;; structure, #S(x y x-scale y-scale), which is mainly for internal use
;;; but is also available as an input form. And all of these points
;;; can be wrapped up in various kinds of sequences.

;;; What led to the defstruct was a need to selectively specify
;;; whether or not points are scaled.


(defun pt-printer (p s k)
  (declare (ignore k))
  (if *print-readably*
    (format s "#S(pt :x ~S :y ~S :x-scale ~S :y-scale ~S) "
            (pt-x p)
            (pt-y p)
            (pt-x-scale p)
            (pt-y-scale p))
    (format s "[~S ~S ~S ~S]"
            (pt-x p) 
            (pt-y p) 
            (pt-x-scale p) 
            (pt-y-scale p))))


(defstruct (pt (:print-function pt-printer))
  (x 0.0)
  (y 0.0)
  (x-scale t)
  (y-scale t))






;;;;;;;;;;;;;;;;;;;;;;;       LIPS.LISP        ;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;   Lisp to Postscript   ;;;;;;;;;;;;;;;;;;;;;;;;;

;; The 'pgm' argument is a list of lists, where each component list
;; is a graphics command to be translated into Postscript. For example:
;;
;; ((moveto 0 0)
;;  (lineto (10 . 10))
;;  (setrgbcolor (0.5 0.1 1.0))
;;  (stroke)
;;  (polygon (1 1) (3 3) (0 1))
;;  (setrgbcolor 1 0 0)
;;  (fill))
;;
;; Note that x y coordinates can be supplied in any of three different
;; forms: (moveto 0 0), (moveto (0 . 0)) and (moveto (0 0)) all produce
;; the same output. In other words, a point can consist of two numbers,
;; a dotted pair of numbers or a two-element list of numbers. Also a color
;; specification can be given either as plain numeric arguments or as a
;; list of numbers.

;;;;;; COMMAND LIST ;;;;;;;;

;; (newpath)
;; (moveto x y)                 ; or (moveto (x . y)) or (moveto (x y))
;; (rmoveto dx dy)
;; (lineto x y)
;; (rlineto dx dy)
;; (arc center-x center-y radius start-degrees end-degrees)
;; (arct x1 y1 x2 y2 radius)
;; (curveto x1 y1 x2 y2 x3 y3)
;; (rcurveto dx1 dy1 dx2 dy2 dx3 dy3)
;; (closepath)
;; (stroke)
;; (fill)
;; (clip)
;; (gsave)
;; (grestore)
;; (translate x y)
;; (rotate degrees)
;; (scale x-factor y-factor)
;; (setcmykcolor (c m y k))      ; all color and gray values
;; (setrgbcolor (r g b))         ; range from 0.0 to 1.0;
;; (sethsbcolor (h s b))         ; in all four cases args can
;; (setgray g)                   ; be numbers or list of numbers
;; (setlinewidth n)
;; (setlinecap k)                ; k = 0, 1 or 2, and must
;; (setlinejoin k)               ; be integer, not float
;; (setdash (a b c ...) p)       ; the a, b, c... values are dash lengths, p is phase
;; (show text)                   ; text is a string, will be printed flushleft
;; (showright text)              ; text is a string, will be printed flush right
;; (showcenter text)             ; text is a string, will be printed centered
;; (font name size)
;; (stroke-fill)
;; (comment string)
;; (line x1 y1 x2 y2)
;; (polyline x1 y1 ... )         ; any even number of x,y pairs
;; (polygon x1 y1 ... )          ; automatically closed
;; (rectangle llx lly urx ury)
;; (circle center-x center-y r)
;; (dot x y diameter)            ; note -- not radius

(defun lips (pgm &optional filename)
  
  (let ((filename (or filename
                      (gui::cocoa-choose-new-file-dialog))))
    (with-open-file (destination filename :direction :output
                                          :if-exists :supersede)
      
      (labels
        
        ((emit-ps (&rest args)
             (nlet loop ((args args))
               (cond ((null args) (format destination "~%"))
                     ((= 1 (length args)) (emit-item (car args))
                                          (format destination "~%"))
                     (t (emit-item (car args))
                        (format destination " ")
                        (loop (cdr args))))))

           (emit-item (arg)
             (typecase arg
               (integer (format destination "~D" arg))
               (number  (format destination "~9,4F" arg))
               (string  (format destination "~A" arg))))
           
           (emit-ps-prologue ()
             (emit-ps "%!PS-Adobe-2.0 EPSF-2.0")
             (emit-ps "%%Creator: lips.lisp")
             (emit-ps "%%BeginDocument")
             (emit-ps "%%BoundingBox: -1000 -1000 1000 1000")
             (emit-ps "%%Pages: 1")
             (emit-ps "%%EndComments")
             (emit-ps)
             
             (emit-ps "/showright {           % string")
             (emit-ps "  dup stringwidth pop  % string dx")
             (emit-ps "  neg 0                % string -dx 0")
             (emit-ps "  rmoveto show } def   % --")
             (emit-ps)
             
             (emit-ps "/showcenter {          % string")
             (emit-ps "  dup stringwidth pop  % string dx")
             (emit-ps "  2 div neg 0          % string -dx 0")
             (emit-ps "  rmoveto show } def   % --")
             (emit-ps)
             
             (emit-ps "/dot {                 % x y r")
             (emit-ps "  0 360 arc            % --")
             (emit-ps "  closepath } def      % --")
             
             (emit-ps)
             (emit-ps "%%EndProlog")
             (emit-ps)
             (emit-ps "%%Page 1"))
           
           (emit-ps-graphics-defaults ()
             (emit-ps 0 0 0 1 "setcmykcolor")
             (emit-ps 1 "setlinewidth")
             (emit-ps 0 "setlinecap")               ; buttcap
             (emit-ps 0 "setlinejoin")              ; miterjoin
             (emit-ps "[] 0 setdash"))

           (emit-ps-epilogue ()
             (emit-ps "%%EndDocument")
             (emit-ps "%%EOF"))
           
           
           ;; The aim here is to tolerate any plausible list or cons structure for
           ;; the arguments to commands. Some examples that should work: (1 2 3 4),
           ;; ((1 2) (3 4), ((1 . 2) (3 . 4)) ((1 2 3 4)), (((1 2) 3) 4) and many
           ;; even wilder structures should all return (1 2 3 4)
           
           
           (flatten-arglist (tree)
             (cond ((null tree) nil)
                   ((atom tree) (list tree))
                   ((atom (car tree))
                    (cons (car tree) (flatten (cdr tree))))
                   (t (append (flatten (car tree))
                              (flatten (cdr tree))))))
           
           (check-numeric-args (arglist number-of-args)
             (and (= number-of-args (length arglist))
                  (every #'numberp arglist)))

           (lips-warn (msg stmt action)
             (format t "lips warning: ~A in ~% ~S~%   ~A~%" msg stmt action)))
           
           
          ;; END OF LABELS PROCEDURES
          ;; START OF MAIN LOOP


          (emit-ps-prologue)
          (emit-ps-graphics-defaults)

          (dolist (stmt pgm)
            (let ((command (car stmt))
                  (args (flatten-arglist (cdr stmt))))
              (case command
                
                (newpath       (unless (null args)
                                 (lips-warn "Extra args to newpath" stmt "Command issued anyway."))
                               (emit-ps "newpath"))
                
                (moveto        (if (check-numeric-args args 2)
                                 (emit-ps (first args) (second args) "moveto")
                                 (lips-warn "Aberrant args to moveto" stmt "Command skipped.")))
                
                (rmoveto       (if (check-numeric-args args 2)
                                 (emit-ps (first args) (second args) "rmoveto")
                                 (lips-warn "Aberrant args to rmoveto" stmt "Command skipped.")))
                 
                (lineto        (if (check-numeric-args args 2)
                                 (emit-ps (first args) (second args) "lineto")
                                 (lips-warn "Aberrant args to lineto" stmt "Command skipped.")))
                
                (rlineto       (if (check-numeric-args args 2)
                                 (emit-ps (first args) (second args) "rlineto")
                                 (lips-warn "Aberrant args to rlineto" stmt "Command skipped.")))
                 
                (arc           (if (check-numeric-args args 5)  ; x y r theta1 theta2
                                 (emit-ps (first args) (second args) (third args) 
                                          (fourth args) (fifth args) "arc")
                                 (lips-warn "Aberrant args to arc" stmt "Command skipped.")))
                 
                (arct          (if (check-numeric-args args 5)
                                 (emit-ps (first args) (second args) (third args) 
                                          (fourth args) (fifth args) "arct")
                                 (lips-warn "Aberrant args to arct" stmt "Command skipped.")))

                (curveto       (if (check-numeric-args args 6)
                                 (emit-ps (first args) (second args) (third args) 
                                          (fourth args) (fifth args) (sixth args) "curveto")
                                 (lips-warn "Aberrant args to curveto" stmt "Command skipped.")))
                
                (rcurveto      (if (check-numeric-args args 6)
                                 (emit-ps (first args) (second args) (third args) 
                                          (fourth args) (fifth args) (sixth args) "rcurveto")
                                 (lips-warn "Aberrant args to rcurveto" stmt "Command skipped.")))
                 
                (closepath     (unless (null args)
                                 (lips-warn "Extra args to closepath" stmt "Command issued anyway."))
                               (emit-ps "closepath"))
                
                (stroke        (unless (null args)
                                 (lips-warn "Extra args to stroke" stmt "Command issued anyway."))
                               (emit-ps "stroke"))
                
                (fill          (unless (null args)
                                 (lips-warn "Extra args to fill" stmt "Command issued anyway."))
                               (emit-ps "fill"))
                
                (clip          (unless (null args)
                                 (lips-warn "Extra args to clip" stmt "Command issued anyway."))
                               (emit-ps "clip"))
                
                (gsave         (unless (null args)
                                 (lips-warn "Extra args to gsave" stmt "Command issued anyway."))
                               (emit-ps "gsave"))
                
                (grestore      (unless (null args)
                                 (lips-warn "Extra args to grestore" stmt "Command issued anyway."))
                               (emit-ps "grestore"))
                
                (translate     (if (check-numeric-args args 2)
                                 (emit-ps (car args) (cadr args) "translate")
                                 (lips-warn "Aberrant args to translate" stmt "Command skipped.")))
                
                (rotate        (if (check-numeric-args args 1)
                                 (emit-ps (car args) "rotate")
                                 (lips-warn "Aberrant args to rotate" stmt "Command skipped.")))
                
                (scale         (if (check-numeric-args args 2)
                                 (emit-ps (car args) (cadr args) "scale")
                                 (lips-warn "Aberrant args to scale" stmt "Command skipped.")))
                
                (setcmykcolor  (cond ((and (= 1 (length args))
                                           (listp (car args))
                                           (= 4 (length (car args)))
                                           (every #'numberp (car args)))
                                      (let ((colors (car args)))
                                        (emit-ps (first colors) (second colors)
                                                 (third colors) (fourth colors) "setcmykcolor")))
                                     ((and (= 4 (length args))
                                           (every #'numberp args))
                                      (emit-ps (first args) (second args)
                                               (third args) (fourth args) "setcmykcolor"))
                                     (t (lips-warn "Aberrant args to setcmykcolor" stmt "Command skipped."))))
                 
                (setrgbcolor   (cond ((and (= 1 (length args))
                                           (listp (car args))
                                           (= 3 (length (car args)))
                                           (every #'numberp (car args)))
                                      (let ((colors (car args)))
                                        (emit-ps (first colors) (second colors)
                                                 (third colors) "setrgbcolor")))
                                     ((and (= 3 (length args))
                                           (every #'numberp args))
                                      (emit-ps (first args) (second args)
                                               (third args) "setrgbcolor"))
                                     (t (lips-warn "Aberrant args to setrgbcolor" stmt "Command skipped."))))
                 
                (setgray       (cond ((check-numeric-args args 1)
                                      (emit-ps (car args) "setgray"))
                                     ((and (= 1 (length args))
                                           (listp (car args))
                                           (= 1 (length (car args)))
                                           (numberp (caar args)))
                                      (emit-ps (caar args) "setgray"))
                                     (t (lips-warn "Aberrant args to setgray" stmt "Command skipped."))))
                 
                (sethsbcolor   (cond ((and (= 1 (length args))
                                           (listp (car args))
                                           (= 3 (length (car args)))
                                           (every #'numberp (car args)))
                                      (let ((colors (car args)))
                                        (emit-ps (first colors) (second colors)
                                                 (third colors) "sethsbcolor")))
                                     ((and (= 3 (length args))
                                           (every #'numberp args))
                                      (emit-ps (first args) (second args)
                                               (third args) "sethsbcolor"))
                                     (t (lips-warn "Aberrant args to sethsbcolor" stmt "Command skipped."))))
                 
                (setlinewidth  (if (check-numeric-args args 1)
                                 (emit-ps (car args) "setlinewidth")
                                 (lips-warn "Aberrant args to setlinewidth" stmt "Command skipped.")))
                 
                (setlinecap    (if (check-numeric-args args 1)
                                 (emit-ps (car args) "setlinecap")
                                 (lips-warn "Aberrant args to setlinecap" stmt "Command skipped.")))
                 
                (setlinejoin   (if (check-numeric-args args 1)
                                 (emit-ps (car args) "setlinejoin")
                                 (lips-warn "Aberrant args to setlinejoin" stmt "Command skipped.")))
                 
                (setdash       (if (and (= 2 (length args))
                                        (and (listp (first args))
                                             (every #'numberp (first args)))
                                        (numberp (second args)))
                                 (apply #'emit-ps (append '("[") 
                                                          (first args)
                                                          '("]")
                                                          (cdr args)))
                                 (lips-warn "Aberrant args to setdash" stmt "Command skipped.")))
                 
                (show          (if (and (= 1 (length args))
                                        (stringp (car args)))
                                 (emit-ps (concatenate 'string "(" (car args) ") show"))
                                 (lips-warn "Aberrant args to show" stmt "Command skipped.")))
                
                
                ;;; NOTE -- All commands above this line are direct translations of standard
                ;;; Postscript syntax. That is, the command name is spelled the same as a Postscript
                ;;; command, and the arguments closely match those expected by a Postscript interpreter.
                ;;; The commands below this line include higher-level additions to the Postscript
                ;;; repertory and some aberrations and variations.
                
                
                (showright     (if (and (= 1 (length args))
                                        (stringp (car args)))
                                 (emit-ps (concatenate 'string "(" (car args) ") showright"))
                                 (lips-warn "Aberrant args to showright" stmt "Command skipped.")))
                
                (showcenter    (if (and (= 1 (length args))
                                        (stringp (car args)))
                                 (emit-ps (concatenate 'string "(" (car args) ") showcenter"))
                                 (lips-warn "Aberrant args to showcenter" stmt "Command skipped.")))
                
                ;; this combines three Postscript commands: findfont, scalefont and setfont 
                
                (font          (if (and (= 2 (length args))
                                        (stringp (first args))
                                        (numberp (second args)))
                                 (emit-ps (concatenate 'string "/" (first args))
                                          "findfont"
                                          (second args)
                                          "scalefont setfont")
                                 (lips-warn "Aberrant args to font" stmt "Command skipped.")))
                                
                (stroke-fill   (unless (null args)
                                 (lips-warn "Extra args to stroke-fill" stmt "Command issued anyway."))
                               (emit-ps "gsave stroke grestore fill"))
                
                (comment       (emit-ps)
                               (emit-ps "%" (car args))
                               (emit-ps))
                                            
                (line          (if (check-numeric-args args 4)
                                 (progn
                                   (emit-ps "newpath")
                                   (emit-ps (first args) (second args) "moveto")
                                   (emit-ps (third args) (fourth args) "lineto"))
                                 (lips-warn "Aberrant args to line" stmt "Command skipped.")))
                 
                (polyline      (if (and (evenp (length args))
                                        (>= (length args) 2)
                                        (every #'numberp args))
                                 (progn
                                   (emit-ps "newpath")
                                   (emit-ps (first args) (second args) "moveto")
                                   (nlet loop ((pts (cddr args)))
                                     (unless (endp pts)
                                       (emit-ps (first pts) (second pts) "lineto")
                                       (loop (cddr pts)))))
                                 (lips-warn "Aberrant args to polyline" stmt "Command skipped.")))
                
                (polygon       (if (and (evenp (length args))
                                        (>= (length args) 2)
                                        (every #'numberp args))
                                 (progn
                                   (emit-ps "newpath")
                                   (emit-ps (first args) (second args) "moveto")
                                   (nlet loop ((pts (cddr args)))
                                     (unless (endp pts)
                                       (emit-ps (first pts) (second pts) "lineto")
                                       (loop (cddr pts))))
                                   (emit-ps "closepath"))
                                 (lips-warn "Aberrant args to polygon" stmt "Command skipped.")))
                
                (rectangle     (if (check-numeric-args args 4)
                                 (let ((x1 (first args))
                                       (y1 (second args))
                                       (x2 (third args))
                                       (y2 (fourth args)))
                                   (emit-ps "newpath")
                                   (emit-ps x1 y1 "moveto")
                                   (emit-ps x2 y1 "lineto")
                                   (emit-ps x2 y2 "lineto")
                                   (emit-ps x1 y2 "lineto")
                                   (emit-ps "closepath"))
                                 (lips-warn "Aberrant args to rectangle" stmt "Command skipped.")))
                 
                (circle        (if (check-numeric-args args 3)    ;; center-x center-y radius
                                 (progn
                                   (emit-ps "newpath")
                                   (emit-ps (first args) (second args) (third args) 0 360 "arc")
                                   (emit-ps "closepath"))
                                 (lips-warn "Aberrant args to circle" stmt "Command skipped.")))
                
                (dot           (if (check-numeric-args args 3)    ;; center-x center-y diameter
                                 (progn
                                   (emit-ps "newpath")
                                   (emit-ps (first args) (second args) (/ (third args) 2) "dot")
                                   (emit-ps "fill"))
                                 (lips-warn "Aberrant args to dot" stmt "Command skipped."))))))
          
          ;;;; END OF DOLIST MAIN LOOP
                    
          
          (emit-ps-epilogue))
    
        (format t "~A written.~%" filename))))          ; end of (defun lips .... )



;; end of LIPS.LISP





;;;;;;;;;;;;;;;;;;;;;;;         PLOT.LISP          ;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;   draw graphs and charts   ;;;;;;;;;;;;;;;;;;;;;;;;;

;; See guide to arguments and calling protocol and the details of the
;; drawing command language at the top of this file.


(defun plot (data
       &key (filename nil)
            (x-min nil)
            (x-max nil)
            (y-min nil)
            (y-max nil)
            (width 400)
            (height 250)
            (transform-x-fn #'identity)
            (transform-y-fn #'identity)
            (line-thickness 1.0)
            (line-color cmyk:red)
            (dot-diameter 2.0)
            (bkgd-color cmyk:putty)
            (grid-color cmyk:white)
            (grid-thickness 0.5)
            (grids-latitudinal nil)
            (grids-longitudinal nil)
            (frame-bottom t)
            (frame-left t)
            (tick-color cmyk:black)
            (tick-thickness 0.5)
            (tick-length -3)
            (ticks-bottom nil)
            (ticks-left nil)
            (tick-labels-bottom t)
            (tick-labels-bottom-format-string "~S")
            (tick-labels-bottom-x-adj 0.0)
            (tick-labels-bottom-y-adj -0.5)
            (tick-labels-left t)
            (tick-labels-left-format-string "~S")
            (tick-labels-left-x-adj 1.4)
            (tick-labels-left-y-adj -1.0)
            (axis-label-bottom nil)
            (axis-label-left nil)
            (label-font-name "Helvetica")
            (label-font-size 8)
            (debug nil))
  
  (let ((background-layer nil)                 ;; here's where we'll accumulate
        (content-layer nil)                    ;; the drawing commands
        (foreground-layer nil)
        (the-graph nil)
        
        (glyphlist
         '((diamond      ((moveto  0.0  0.5)
                          (lineto  0.5  0.0)
                          (lineto  0.0 -0.5)
                          (lineto -0.5  0.0)
                          (closepath)))

           (square       ((moveto -0.5  0.5)
                          (lineto  0.5  0.5)
                          (lineto  0.5 -0.5)
                          (lineto -0.5 -0.5)
                          (closepath)))
           
           (triangle     ((moveto 0 0.433)
                          (lineto 0.5 -0.866)
                          (lineto -1 0)
                          (closepath)))
           
           (cross        ((moveto  0.167  0.500)
                          (lineto  0.167  0.167)
                          (lineto  0.500  0.167)
                          (lineto  0.500 -0.167)
                          (lineto  0.167 -0.167)
                          (lineto  0.167 -0.500)
                          (lineto -0.167 -0.500)
                          (lineto -0.167 -0.167)
                          (lineto -0.500 -0.167)
                          (lineto -0.500  0.167)
                          (lineto -0.167  0.167)
                          (lineto -0.167  0.500)
                          (closepath)))
                                     
           (tee          ((lineto 0 1)                  ; maybe useful for error bars
                          (rmoveto -0.5 0)
                          (rlineto 0.5 0)))))
        
        (tick-labels-left-max-chars 0))
    
    (labels
      ((emitc (&rest args)
         (push args content-layer))
       
       (emitb (&rest args)
         (push args background-layer))
       
       (emitf (&rest args)
         (push args foreground-layer))
       
       (get-keyword-value (keyword arglist)
         (nlet loop ((args arglist))
           (if (or (null args) (null (cdr args)))
             nil
             (if (eq keyword (car args))
               (cadr args)
               (loop (cdr args))))))       
       
       (find-extrema (tree)
         (let ((minx nil) (maxx nil) (miny nil) (maxy nil))
           (labels ((min* (a b)
                      (cond ((and (numberp a) (numberp b))
                             (min a b))
                            ((numberp a) a)
                            ((numberp b) b)
                            (t nil)))
                    (max* (a b)
                      (cond ((and (numberp a) (numberp b))
                             (max a b))
                            ((numberp a) a)
                            ((numberp b) b)
                            (t nil))))
             (nlet loop ((cmds tree))
               (cond ((or (null cmds) (atom cmds)))
                     ((listp (car cmds))
                      (loop (car cmds))
                      (loop (cdr cmds)))
                     ((pt-p (car cmds))
                      (let ((p (car cmds)))
                        (when (pt-x-scale p)
                          (setf minx (min* minx (pt-x p)))
                          (setf maxx (max* maxx (pt-x p))))
                        (when (pt-y-scale p)
                          (setf miny (min* miny (pt-y p)))
                          (setf maxy (max* maxy (pt-y p))))
                        (loop (cdr cmds))))
                     (t (loop (cdr cmds)))))
             (unless (numberp x-min) (setf x-min minx))
             (unless (numberp x-max) (setf x-max maxx))
             (unless (numberp y-min) (setf y-min miny))
             (unless (numberp y-max) (setf y-max maxy)))))      

       (apply-transforms (cmdtree)
         (cond ((null cmdtree))    ; done with this branch
               ((pt-p cmdtree) (when (pt-x-scale cmdtree)
                                 (setf (pt-x cmdtree) 
                                       (funcall transform-x-fn (pt-x cmdtree))))
                               (when (pt-y-scale cmdtree)
                                 (setf (pt-y cmdtree) 
                                       (funcall transform-y-fn (pt-y cmdtree)))))
               ((atom cmdtree))
               ((consp cmdtree) (apply-transforms (car cmdtree))
                                (apply-transforms (cdr cmdtree)))))
       
       
       (scale-points (tree)

         (let ((x-factor (/ width (- x-max x-min)))
               (y-factor (/ height (- y-max y-min))))

           (labels
             ((scale-a-point (p)
                (let ((x (if (pt-x-scale p) 
                           (float (* (- (pt-x p) x-min) x-factor))
                           (float (pt-x p))))
                      (y (if (pt-y-scale p) 
                           (float (* (- (pt-y p) y-min) y-factor))
                           (float (pt-y p)))))
                  (cons x y))))
             
             (nlet loop ((cmds tree))
               (cond ((or (null cmds) (atom cmds)))
                     ((listp (car cmds))
                      (loop (car cmds))
                      (loop (cdr cmds)))
                     ((pt-p (car cmds))
                      (setf (car cmds) (scale-a-point (car cmds)))
                      (loop (cdr cmds)))
                     (t (loop (cdr cmds)))))))))




      ;;;; CHECK AND REFORMAT INPUT DATA
      ;;;; 
      ;;;; The 'data' argument to PLOT is expected to be a list of lists,
      ;;;; where each component list is a plotting command, with a keyword
      ;;;; in the car position. But there are two other possibilities we
      ;;;; want to allow -- a single command, such as (plotline ((x y) ... )),
      ;;;; or simply a list of numbers or points without keywords. The latter
      ;;;; is interpreted as a request to plot those points or numbers with
      ;;;; all default options. There's also no reason why we shouldn't
      ;;;; accept a vector as the outermost wrapper. (In principle we could
      ;;;; allow vectors and lists to be chosen freely at all levels of the
      ;;;; data structure, but I'm too lazy. An outermost vector is okay, and
      ;;;; a vector #(x y) to represent a point is okay, but otherwise it's
      ;;;; got to be lists.


      ;; Try to validate and perhaps reformat the input data. First, if 'data'
      ;; is anything other than a sequence, we're hopelessly lost. Next, if
      ;; the input is a vector, make a list.
      
      (unless (sequencep data)
        (format t "The 'data' argument to PLOT should be a~%~
                   sequence of numbers or points or commands.~%~
                   Can't plot ~S~%" data)
        (abort))
    
      (when (vectorp data) 
        (setf data (coerce data 'list)))
      
      
      ;; Now we know we're dealing with a list. The first possibility is
      ;; a list of lists, each of which has a symbol as its car. This is the
      ;; signature of a properly formed PLOT program.
      
      (cond ((every #'(lambda (x) (and (listp x) (symbolp (car x)))) data)) ; okay for now
            
            ; if it's not a list of commands, maybe it's a single
            ; command, which we put into a list for later processing
            
            ((symbolp (car data)) (setf data (list data)))    ; (data) --> ((data))
            
            ; Another possibility is an empty list of commands, which you
            ; might try when testing various options. We'll allow this,
            ; and avoid later trouble by inserting a do-nothing command.

            ((null data)
             (setf data '((comment "PLOT: Empty drawing."))))
            
            ; if it's neither a command nor a list of commands, then our
            ; only hope is a list of points or numbers, for which we'll
            ; create a simple line graph. So we try to canonize the list.
            
            (t (let ((pointlist (canonize-points data)))
                 (if pointlist
                   (setf data (list (cons 'plotline pointlist)))
                   (progn
                     (format t "Failed to parse the 'data' argument to PLOT. ~%")
                     (abort))))))
      
      
      ;; If we have gotten this far, 'data' consists of a list
      ;; of lists, where each of the component lists has a symbol
      ;; as its car. We hope that symbol designates a command known
      ;; to either PLOT or LIPS. Eventually we'll find out.


      
      ;;;;; THE CONTENT LAYER
      ;;;;; 
      ;;;;; This is where the actual plotting of data takes place. After
      ;;;;; some setting-up preliminaries, we're going to process the
      ;;;;; 'data' commands in sequence, building up the drawing. 
      ;;;;; 
      ;;;;; Note that at this point we're still working in unscaled
      ;;;;; and untransformed user-coordinate space. And all geometry
      ;;;;; will be entered into the command lists as pt structs. 
      ;;;;; We'll do the rescaling and transforming later, and also
      ;;;;; convert all pt structs into simple dotted pairs.
      
      
      ;; For the content layer, we start by drawing a clipping rectangle and 
      ;; setting a few default graphics parameters, which may or may not be 
      ;; overridden by later commands.
    
      (emitc 'comment "PLOT: Start of content layer.")
      (emitc 'gsave)
      (emitc 'rectangle (cons 0 0) (cons width height))
      (emitc 'clip)
      (emitc 'setlinewidth line-thickness)
      (emitc 'setlinecap roundcap)
      (emitc 'setlinejoin roundjoin) 
      (emitc 'setcmykcolor line-color)
      (emitc 'font label-font-name label-font-size)
      (emitc 'comment "PLOT: Start of drawing commands.")
    
        
      ;; Now process the commands one by one. The various commands defined in
      ;; PLOT are handled individually. Everything else is just passed on to
      ;; LIPS, on the assumption that it must be a LIPS command. If we're
      ;; wrong about that, we won't find out until LIPS tells us. (BUT:
      ;; Commands meant for LIPS that have geometric points among their
      ;; arguments will be properly scaled and transformed only if those
      ;; points are encoded in pt structs.)
      
    
      (dolist (cmd data)

        (case (car cmd)
          
          (plotline (let ((pts (canonize-points (cdr cmd))))
                      (if pts
                        (progn
                          (emitc 'polyline pts)
                          (emitc 'stroke))
                        (format t "Couldn't make sense of the argument to ~
                                   plotline. Skipping command.~%~S~%" cmd))))
          
          (plotarea (let ((pts (canonize-points (cdr cmd))))
                      (if pts
                        (let ((first-pt (car pts))
                              (last-pt (car (last pts))))
                          (let ((bottom-first (make-pt :x (pt-x first-pt)
                                                       :y 0
                                                       :x-scale t
                                                       :y-scale nil))
                                (bottom-last  (make-pt :x (pt-x last-pt)
                                                       :y 0
                                                       :x-scale t
                                                       :y-scale nil)))
                            (let ((augmented-pts 
                                   (append (list bottom-first)
                                           pts 
                                           (list bottom-last))))
                              (emitc 'polygon augmented-pts)
                              (emitc 'fill))))
                        (format t "Couldn't make sense of the argument to ~
                                   plotarea. Skipping command.~%~S~%" cmd))))
          
          (plotdots (let ((pts (canonize-points (cdr cmd))))
                      (if pts
                        (dolist (pt pts)
                          (emitc 'dot pt dot-diameter))
                        (format t "Couldn't make sense of the argument to ~
                                   plotdots. Skipping command.~%~S~%" cmd))))
          
          (setdotdiameter (let ((new-diameter (cadr cmd)))
                            (if (numberp new-diameter)
                              (setf dot-diameter new-diameter)
                              (format t "Attempt to set the dot diameter to a weird ~
                                         value. Command skipped.~%~S~%" cmd))))
          
          (plotvector (let ((args (cdr cmd)))
                        (let ((from (car (canonize-points (first args))))
                              (magnitude (second args))
                              (direction (third args)))
                          (if (and from 
                                   (numberp magnitude)
                                   (numberp direction))
                            (let* ((dx (* magnitude (cos (degrees-to-radians direction))))
                                   (dy (* magnitude (sin (degrees-to-radians direction))))
                                   (to (make-pt :x (+ (pt-x from) dx)
                                                :y (+ (pt-y from) dy))))
                              (emitc 'line from to)
                              (emitc 'stroke)
                              (emitc 'gsave)
                              (emitc 'translate to)
                              (emitc 'rotate direction)
                              (emitc 'setlinecap buttcap)
                              (emitc 'setlinejoin miterjoin)
                              (emitc 'moveto -3 3)
                              (emitc 'lineto 0 0)
                              (emitc 'lineto -3 -3)
                              (emitc 'stroke)
                              (emitc 'grestore))
                            (format t "Couldn't make sense of the arguments to ~
                                   plotvector. Skipping command.~%~S~%" cmd)))))
                              

          (plotvector-abs (let ((args (cdr cmd)))
                            (let ((from (car (canonize-points (first args))))
                                  (magnitude (second args))
                                  (direction (third args)))
                              (if (and from 
                                       (numberp magnitude)
                                       (numberp direction))
                                (let ((dx (* magnitude (cos (degrees-to-radians direction))))
                                      (dy (* magnitude (sin (degrees-to-radians direction)))))
                                  (emitc 'moveto from)
                                  (emitc 'rlineto dx dy)
                                  (emitc 'stroke)
                                  (emitc 'gsave)
                                  (emitc 'translate from)
                                  (emitc 'translate dx dy)
                                  (emitc 'rotate direction)
                                  (emitc 'setlinecap buttcap)
                                  (emitc 'setlinejoin miterjoin)
                                  (emitc 'moveto -3 3)
                                  (emitc 'lineto 0 0)
                                  (emitc 'lineto -3 -3)
                                  (emitc 'stroke)
                                  (emitc 'grestore))
                                (format t "Couldn't make sense of the arguments to ~
                                           plotvector. Skipping command.~%~S~%" cmd)))))


          
          ;; NOTE the following two commands do not do a stroke or fill. The
          ;; command has to be supplied separately.
          
          (plotpolygon (let ((pts (canonize-points (cdr cmd))))
                         (if pts
                           (emitc 'polygon pts)
                           (format t "Couldn't make sense of the argument to ~
                                   plotpolygon. Skipping command.~%~S~%" cmd))))
          
          (plotrectangle (let ((pts (canonize-points (cdr cmd))))
                           (if (and pts (= (length pts) 2))
                             (emitc 'rectangle pts)
                             (format t "'Plotrectangle' expects exactly two ~
                                   points. Skipping command.~%~S~%" cmd))))
          
          

               ;; BEWARE the special syntax of the plotglyphs command. It should
               ;; look like:
               ;; 
               ;;   (plotglyphs ((x y) ...) :glyph tee :scale-x 5 :scale-y 2 
               ;;                           :rotate 90 :render fill)
               ;; 
               ;; The tricky part here is that you must say (list 'plotglyphs pts ...)
               ;; not (cons 'plotglyphs ....) For other commands, either list or cons
               ;; will work.
               ;; 
               ;; There are defaults for all the keyword arguments. Other keywords are
               ;; not prohibited, but they'll be ignored.
               ;; 
               ;; Also note: For stroked glyphs, the linewidth will be scaled along
               ;; with everything else. So either define within the glyph or pre-scale
               ;; it to what you want.
          
          (plotglyphs (let ((args (cdr cmd)))
                        (let ((pts (canonize-points (first args)))
                              (glyph-name (or (get-keyword-value :glyph args) 'square))
                              (scale-x (or (get-keyword-value :scale-x args) 1))
                              (scale-y (or (get-keyword-value :scale-y args) 1))
                              (degrees (or (get-keyword-value :rotate args) 0))
                              (render  (or (get-keyword-value :render args) 'fill)))
                          (let ((glyph-cmds (cadr (assoc glyph-name glyphlist))))
                            (if (and pts glyph-cmds
                                     (member render '(fill stroke stroke-fill) :test #'eq))
                              (dolist (pt pts)
                                (emitc 'gsave)
                                (emitc 'translate pt)
                                (emitc 'scale scale-x scale-y)
                                (emitc 'rotate degrees)
                                (emitc 'newpath)
                                (emitc 'moveto 0 0)
                                (dolist (glyphcmd glyph-cmds)
                                  (push glyphcmd content-layer))
                                (case render
                                  (fill (emitc 'fill))
                                  (stroke (emitc 'stroke))
                                  (stroke-fill (emitc 'stroke-fill)))
                                (emitc 'grestore))
                              (format t "Couldn't make sense of the arguments to ~
                                   plotglyphs. Skipping command.~%~S~%" cmd))))))
          
          
               ;; In defineglyph the right calling protocol is something like
               ;; (list 'defineglyph 'name ((cmd1 ...) (cmd2 ...)))
          
          (defineglyph (let ((args (cdr cmd)))
                         (if (and (symbolp (car args))
                                  (properlistp (cdr args)))
                           (push args glyphlist))))
          
          
               ;; NOTE ARGUMENTS (plotlabel (x y) "string" 'left)
               ;; The allowable third arguments are 'left 'center 'right
               ;; The argument is optional; if it is not supplied, the
               ;; default is 'center
          
          (plotlabel (let ((args (cdr cmd)))
                       (let ((position (car (canonize-points (first args))))
                             (strng (second args))
                             (alignment (or (third args) 'center)))
                         (if (and position 
                                  strng 
                                  (member alignment '(left center right)))
                           (progn
                             (emitc 'moveto position)
                             (case alignment
                               (left   (emitc 'show strng))
                               (center (emitc 'showcenter strng))
                               (right  (emitc 'showright strng))))
                           (format t "Couldn't make sense of the arguments to ~
                                   plotlabel. Skipping command.~%~S~%" cmd)))))
                             
          (t (push cmd content-layer))))
          
          
      (emitc 'comment "PLOT: End of drawing commands.")
      (emitc 'grestore)
      (emitc 'comment "PLOT: End of content layer.")
      
      ;;;; Now that the content-layer is complete, we can go through
      ;;;; the list of commands and determine the extreme points. But
      ;;;; we're not ready yet to apply transformations or scaling.
      
      (find-extrema content-layer)
      
      
      
      
      
      
      ;;;;;;;; BACKGROUND LAYER ;;;;;;;;;
      
      ;; Here we draw the background box and the grid lines that run
      ;; under the graph.

      (emitb 'comment "PLOT: Start of background layer.")
      (emitb 'gsave)
      (when (cmyk-p bkgd-color)
        (emitb 'setcmykcolor bkgd-color)
        (emitb 'rectangle (cons 0 0) (cons width height))
        (emitb 'fill))
      (emitb 'setlinecap buttcap)
      (emitb 'setlinejoin miterjoin)
      
      
      ;; Gridline positions (also tick marks, which we'll come to later)
      ;; can be specified either by giving an explicit list of coordinates
      ;; or by giving a single number, which will be interpreted as the
      ;; spacing between gridlines. Note that gridlines (but not tickmarks)
      ;; are omitted when they run along an edge of the graph box.
      
      ;; The first step is to check for a numeric argument, and convert it
      ;; into an explicit list of positions with the iota function.
      
      (when (numberp grids-latitudinal)
        (setf grids-latitudinal (iota y-min y-max grids-latitudinal)))
      
      ;; Now we omit the outermost gridlines, if they correspond to boundaries
      ;; of the box, and then draw whatever remains.  
      
      (when grids-latitudinal
        (if (and (listp grids-latitudinal)
                 (every #'numberp grids-latitudinal))
          (progn
            (when (= (first grids-latitudinal) y-min)
              (setf grids-latitudinal (cdr grids-latitudinal)))
            (when (= (car (last grids-latitudinal)) y-max)
              (setf grids-latitudinal (butlast grids-latitudinal)))
            (emitb 'comment "PLOT: Start of latitudinal grid lines.")
            (emitb 'setcmykcolor grid-color)
            (emitb 'setlinewidth grid-thickness)
            (dolist (y grids-latitudinal)
              (let ((endpoints (list (make-pt :x 0     :y y :x-scale nil :y-scale t)
                                     (make-pt :x width :y y :x-scale nil :y-scale t))))
                (emitb 'line endpoints)
                (emitb 'stroke)))
            (emitb 'comment "PLOT: End of latitudinal grid lines."))
          (format t "Can't draw latitudinal gridlines specified as: ~%~S~%" 
                  grids-latitudinal)))
      
      
      ;;; All the same routine now for the longitudinal grids.
      
      (when (numberp grids-longitudinal)
        (setf grids-longitudinal (iota x-min x-max grids-longitudinal)))
      
      (when grids-longitudinal
        (if (and (listp grids-longitudinal)
                 (every #'numberp grids-longitudinal))
          (progn
            (when (= (first grids-longitudinal) x-min)
              (setf grids-longitudinal (cdr grids-longitudinal)))
            (when (= (car (last grids-longitudinal)) x-max)
              (setf grids-longitudinal (butlast grids-longitudinal)))
            (emitb 'comment "PLOT: Start of longitudinal grid lines.")
            (emitb 'setcmykcolor grid-color)
            (emitb 'setlinewidth grid-thickness)
            (dolist (x grids-longitudinal)
              (let ((endpoints (list (make-pt :x x :y 0      :x-scale t :y-scale nil)
                                     (make-pt :x x :y height :x-scale t :y-scale nil))))
                (emitb 'line endpoints)
                (emitb 'stroke)))
            (emitb 'comment "PLOT: End of longitudinal grid lines."))
          (format t "Can't draw longitudinal gridlines specified as: ~%~S~%" 
                  grids-longitudinal)))
          
      (emitb 'grestore)
      (emitb 'comment "PLOT: End of background layer.")
      
      
   
      ;;;;;;;; FOREGROUND LAYER ;;;;;;;;;
      
      ;;; Final steps: Draw a thin black line along the left and the
      ;;; bottom edges of the graph, add tick marks, place type.
      
      (emitf 'comment "PLOT: Start of foreground layer.")
      (emitf 'gsave)
      (emitf 'setcmykcolor tick-color)
      (emitf 'setlinewidth tick-thickness)
      (emitf 'setlinecap buttcap)
      (emitf 'setlinejoin miterjoin)
      (cond ((and frame-bottom frame-left)
             (emitf 'polyline (cons 0 height) 
                              (cons 0 0)
                              (cons width 0))
             (emitf 'stroke))
            (frame-bottom
             (emitf 'line (cons 0 0)
                          (cons width 0))
             (emitf 'stroke))
            (frame-left
             (emitf 'line (cons 0 height)
                          (cons 0 0))
             (emitf 'stroke)))
      
      
      ;; Ticks are handled very similarly to grids. First check to see if the
      ;; argument is a number, which we'll view as the delta interval between
      ;; successive tickmarks. Or, if the arg is a list of numbers, draw them
      ;; at those positions. A sublety is the adjustment of the positions of the
      ;; outermost tickmarks: Move them inward by half their width so that they
      ;; don't hang out beyond the frame. (But only if they in fact coincide
      ;; with the extremes of the frame.) The innermost ticks don't need adjusting
      ;; because of the black boundary line that in itself extends half its width
      ;; beyond the bounding box. Unless there is no such frame.
      
      (when (numberp ticks-bottom)
        (setf ticks-bottom (iota x-min x-max ticks-bottom)))
      
      (when ticks-bottom
        (if (and (listp ticks-bottom)
                 (every #'numberp ticks-bottom))
          (progn
            (emitf 'comment "PLOT: Start of bottom tick marks.")
            (dolist (x ticks-bottom)
              (cond ((and (<= x x-min) (not frame-left))
                     (emitf 'line (make-pt :x (/ tick-thickness 2)
                                           :y 0
                                           :x-scale nil
                                           :y-scale nil)
                                  (make-pt :x (/ tick-thickness 2)
                                           :y tick-length
                                           :x-scale nil
                                           :y-scale nil))
                     (emitf 'stroke))
                    ((>= x x-max)
                     (emitf 'line (make-pt :x (- width (/ tick-thickness 2))
                                           :y 0
                                           :x-scale nil
                                           :y-scale nil)
                                  (make-pt :x (- width (/ tick-thickness 2))
                                           :y tick-length
                                           :x-scale nil
                                           :y-scale nil))
                     (emitf 'stroke))
                    (t (emitf 'line (make-pt :x x
                                             :y 0
                                             :x-scale t
                                             :y-scale nil)
                                    (make-pt :x x
                                             :y tick-length
                                             :x-scale t
                                             :y-scale nil))
                       (emitf 'stroke))))
            (emitf 'comment "PLOT: End of bottom tick marks."))
          (format t "Can't draw bottom tick marks specified as: ~%~S~%" 
                  ticks-bottom)))
      
      (when (numberp ticks-left)
        (setf ticks-left (iota y-min y-max ticks-left)))
      
      (when ticks-left
        (if (and (listp ticks-left)
                 (every #'numberp ticks-left))
          (progn
            (emitf 'comment "PLOT: Start of left-edge tick marks.")
            (dolist (y ticks-left)
              (cond ((and (<= y y-min) (not frame-bottom))
                     (emitf 'line (make-pt :y (/ tick-thickness 2)
                                           :x 0
                                           :x-scale nil
                                           :y-scale nil)
                                  (make-pt :y (/ tick-thickness 2)
                                           :x tick-length
                                           :x-scale nil
                                           :y-scale nil))
                     (emitf 'stroke))
                    ((>= y y-max)
                     (emitf 'line (make-pt :y (- height (/ tick-thickness 2))
                                           :x 0
                                           :x-scale nil
                                           :y-scale nil)
                                  (make-pt :y (- height (/ tick-thickness 2))
                                           :x tick-length
                                           :x-scale nil
                                           :y-scale nil))
                     (emitf 'stroke))
                    (t (emitf 'line (make-pt :y y
                                             :x 0
                                             :x-scale nil
                                             :y-scale t)
                                    (make-pt :y y
                                             :x tick-length
                                             :x-scale nil
                                             :y-scale t))
                       (emitf 'stroke))))
            (emitf 'comment "PLOT: End of left-edge tick marks."))
          (format t "Can't draw left-edge tick marks specified as: ~%~S~%" 
                  ticks-left)))
      
      
      ;;; Finally there's labelling. Let's start with the tick labels. These can
      ;;; be specified as follows. Valid forms of the argument are:
      ;;;
      ;;; -- nil. No labels.
      ;;;
      ;;; -- the Boolean t. In this case, we label each tick with the corresponding
      ;;;    numeric value in user-coordinate space.
      ;;; 
      ;;; -- an atomic value. Gets applied to all ticks
      ;;; 
      ;;; -- a list of values. They are parceled out from left to right or from
      ;;;    bottom to top as the case may be. If we run out of ticks before we
      ;;;    run out of labels, the extras are discarded. If we run out of labels
      ;;;    before we run out of ticks, the remaining ticks are left unlabeled.
      ;;;    The individual labels could be strings, numbers or potentially anything
      ;;;    else printable.
      ;;; 
      ;;; NOTE A TRICK: If you want to leave some ticks unlabeled, use a list of
      ;;; labels, and include the empty string as the label for each unlabeled
      ;;; tick.
      
      
      (emitf 'comment "PLOT: Start of labels.")
      (emitf 'setcmykcolor '(0 0 0 1))
      (emitf 'font label-font-name label-font-size)

      (when tick-labels-bottom
        (let ((y (- (min 0 tick-length) label-font-size tick-labels-bottom-y-adj)))
          (cond ((typep tick-labels-bottom 'boolean)       ; must be t
                 (dolist (x ticks-bottom)
                   (let ((label-str (format nil tick-labels-bottom-format-string x)))
                     (emitf 'moveto (make-pt :x x :y y :x-scale t :y-scale nil))
                     (emitf 'rmoveto tick-labels-bottom-x-adj 0.0)
                     (emitf 'showcenter label-str))))
                ((atom tick-labels-bottom)
                 (let ((label-str (if (stringp tick-labels-bottom)
                                    tick-labels-bottom
                                    (format nil tick-labels-bottom-format-string 
                                            tick-labels-bottom))))
                   (dolist (x ticks-bottom)
                     (emitf 'moveto (make-pt :x x :y y :x-scale t :y-scale nil))
                     (emitf 'rmoveto tick-labels-bottom-x-adj 0.0)
                     (emitf 'showcenter label-str))))
                ((listp tick-labels-bottom)
                 (nlet loop ((ticks ticks-bottom) (labels tick-labels-bottom))
                       (unless (or (endp ticks) (endp labels))
                         (let ((x (car ticks))
                               (label-str (if (stringp (car labels))
                                            (car labels)
                                            (format nil tick-labels-bottom-format-string 
                                                    (car labels)))))
                           (emitf 'moveto (make-pt :x x :y y :x-scale t :y-scale nil))
                           (emitf 'rmoveto tick-labels-bottom-x-adj 0.0)
                           (emitf 'showcenter label-str))
                         (loop (cdr ticks) (cdr labels)))))
                (t (format t "Can't display bottom ticks labels~%~S~%" tick-labels-bottom)))))
      
      
      (when tick-labels-left
        (let ((x (- (min 0 tick-length) tick-labels-left-x-adj)))
          (cond ((typep tick-labels-left 'boolean)       ; must be t
                 (dolist (y ticks-left)
                   (let ((label-str (format nil tick-labels-left-format-string y)))
                     (setf tick-labels-left-max-chars
                           (max tick-labels-left-max-chars
                                (length label-str)))
                     (emitf 'moveto (make-pt :x x
                                             :y y
                                             :x-scale nil
                                             :y-scale t))
                     (emitf 'rmoveto 0 (- (+ (/ label-font-size 2) tick-labels-left-y-adj)))
                     (emitf 'showright label-str))))
                ((atom tick-labels-left)
                 (let ((label-str (if (stringp tick-labels-left)
                                    tick-labels-left
                                    (format nil tick-labels-left-format-string 
                                            tick-labels-left))))
                   (setf tick-labels-left-max-chars
                         (max tick-labels-left-max-chars
                              (length label-str)))
                   (dolist (y ticks-left)
                     (emitf 'moveto (make-pt :x x
                                             :y y
                                             :x-scale nil
                                             :y-scale t))
                     (emitf 'rmoveto 0 (- (+ (/ label-font-size 2) tick-labels-left-y-adj)))
                     (emitf 'showright label-str))))
                ((listp tick-labels-left)
                 (nlet loop ((ticks ticks-left) (labels tick-labels-left))
                   (unless (or (endp ticks) (endp labels))
                     (let ((y (car ticks))
                           (label-str (if (stringp (car labels))
                                        (car labels)
                                        (format nil tick-labels-left-format-string 
                                                (car labels)))))
                       (setf tick-labels-left-max-chars
                             (max tick-labels-left-max-chars
                                  (length label-str)))
                       (emitf 'moveto (make-pt :x x
                                             :y y
                                             :x-scale nil
                                             :y-scale t))
                       (emitf 'rmoveto 0 (- (+ (/ label-font-size 2) tick-labels-left-y-adj)))
                       (emitf 'showright label-str))
                     (loop (cdr ticks) (cdr labels)))))
                (t (format t "Can't display left ticks labels~%~S~%" tick-labels-left)))))
             
      
      ;; The finishing touch: labels for the two axes.

      (when axis-label-bottom
        (let ((y (cond ((and ticks-bottom tick-labels-bottom)
                        (- (min 0 tick-length) (* 2 label-font-size) 1))
                       (ticks-bottom
                        (- (min 0 tick-length) 0))
                       (tick-labels-bottom
                        (- (- label-font-size) 3))
                       (t -3)))
              (x (/ width 2))
              (label-str (if (stringp axis-label-bottom)
                           axis-label-bottom
                           (format nil "~S" axis-label-bottom))))
          (emitf 'moveto x y)
          (emitf 'showcenter label-str)))
      
      
      ;; a problem: We can't calculate how far left to place the label,
      ;; because we don't know the length of the ticks labels -- that's
      ;; calculated by the Postscript interpreter, and we can't do it here
      ;; without digging into font metrics and such. I'm going to punt.
      ;; If left ticks labels exist, I'll move the axis label left by
      ;; five times the font size, thus 40 pts for the usual 8 pt Helvetica.
      ;; Update: a bit much. Try 3x font size.
      
      ;; Further update 2005-05-29. We can at least count characters in
      ;; the tick labels, and thereby make a better guess. While processing
      ;; the left tick labels, above, we keep track of the maximum character
      ;; count in the variable tick-labels-left-max-chars, then we try to
      ;; adjust the offset of the label based on this number. Some measuring
      ;; in Helvetica suggests that the width of the string for numbers
      ;; possibly including commas about 0.5 * fontsize * charcount. The
      ;; extra 2 pts of space provides a small cushion.
      
      (when axis-label-left
        (let ((x (if ticks-left
                   (- (min 0 tick-length) 
                      2 
                      (* 0.5 label-font-size tick-labels-left-max-chars))
                   -2))
              (y (/ height 2))
              (label-str (if (stringp axis-label-left)
                           axis-label-left
                           (format nil "~S" axis-label-left))))
          (emitf 'moveto x y)
          (emitf 'rotate 90)
          (emitf 'showcenter label-str)))
      
      (emitf 'comment "PLOT: End of labels.")
      (emitf 'comment "PLOT: End of foreground layer.")
      (emitf 'grestore)
      
      ;;;;; TRANSFORM AND SCALE
      ;;;;; 
      ;;;;; All the parts are in place now, but we're still living in user
      ;;;;; coordinate space. So we have to apply any coordinate transformations
      ;;;;; and finally scale everything to the artwork coordinates. And we're 
      ;;;;; doing this to all three layers.
      ;;;;; 
      ;;;;; The big guard here is needed for pathological cases -- where
      ;;;;; we have graphed just one point, or none at all, and failed to
      ;;;;; give explicit bounds.

      (when (and (numberp x-min) (numberp x-max)
                 (numberp y-min) (numberp y-max)
                 (plusp (- x-max x-min))
                 (plusp (- y-max y-min)))
                    
        (apply-transforms content-layer)
        (apply-transforms background-layer)
        (apply-transforms foreground-layer)

        (setf x-min (funcall transform-x-fn x-min))
        (setf x-max (funcall transform-x-fn x-max))
        (setf y-min (funcall transform-y-fn y-min))
        (setf y-max (funcall transform-y-fn y-max))
      
        (scale-points content-layer)
        (scale-points background-layer)
        (scale-points foreground-layer))
      
      ;;;;; And finally we can assemble all the pieces in a single long list,
      ;;;;; ready to be turned into Postscript
      
      (setf the-graph (append (nreverse background-layer) 
                              (nreverse content-layer) 
                              (nreverse foreground-layer)))
      
      (if debug
        (dolist (cmd the-graph)
          (pprint cmd))
        (if filename
          (lips the-graph filename)
          (lips the-graph))))))


;;;;; END OF PLOT.LISP ;;;;;











;;;;; CANONICAL FORM OF POINTS

;; Convert various types of arguments to canonical form -- a list of pt
;; structures. The possibilities are, in order:
;; 
;; a. The argument is a single pt; wrap it in a list and return it.
;;       [3 4 t t] ==> ([3 4 t t])
;; 
;; b. The arg is a vector; convert it to a list and try again.  
;; 
;; c. The arg is an atom but neither a pt structure nor a vector. Barf.
;; 
;; d. The arg is a cons whose car and cdr are both numbers, i.e., a
;;    single point in dotted-pair format. Make it a pt, wrap it in a
;;    list, and return it.
;;        (3 . 4) ==> ([3 4 t t])
;; 
;; e. The arg is a two-element proper list whose car and cadr are both
;;    numbers. Interpret this as designating a single point, make it
;;    a pt, wrap it in a list, and return it.
;;        (3 4) ==> ([3 4 t t])
;; 
;; f. The arg is a list already in canonical form, i.e., a list of pts. 
;;    So return it unchanged.
;;        ([3 4 t t] ... ) ==> ([3 4 t t] ... )
;; 
;; g. The arg is a list whose elements are all dotted pairs of numbers.
;;        ((1 . 2) (3 . 4) ... ) ==> ([1 2 t t] [3 4 t t] ... )
;; 
;; h. The arg is a list whose elements are all two-element proper 
;;    lists of numbers.
;;        ((1 2) (3 4) ... ) ==> ([1 2 t t] [3 4 t t] ... )
;; 
;; i. The arg is a list whose elements are all two-element vectors of numbers.
;;        (#(1 2) #(3 4) ... ) ==> ([1 2 t t] [3 4 t t] ... )
;; 
;; j. The list is simply a flat list of numbers, of length greater than 2.
;;    In this case we interpret each number in the list as a y value, and 
;;    associate it with one of the integers in the sequence starting at 1; 
;;    we create pt structures from these x,y pairs. NOTE: The requirment
;;    that the list length must be at least 3 is included so that we can
;;    distinguish case e above, where a two-element list of numbers is taken
;;    to be a single point. This will cause me grief someday.
;;        (6 7 8 ... ) ==> ([1 6 t t] [2 7 t t] [3 8 t t] ... )
;; 
;; k. One final possibility: The argument has one of the structures
;;    outlined above, but it is buried inside the car of a one-element
;;    list. Thus for any one-element sequence that cannot be a one-point
;;    sequence, we try looking inside the first element until we come
;;    either to a qualifying structure or to some other nonsequence.
;;    (Only the list-length check is necessary at this point, because
;;    a one-element list that *does* qualify will have been picked up
;;    by one of the earlier clauses.
;; 
;; l. None of the above -- this must be a list, but the elements are
;;    nothing we can convert into points. So bail out.
;; 
;; Note that one possibility NOT allowed for is a structure that mixes
;; elements from the various clauses above. Thus ((2 . 3) (4 5)) will
;; not pass muster.


(defun canonize-points (pp)

  (cond ((pt-p pp) (list pp))                                ; case a
        
        ((vectorp pp)                                        ; case b
         (canonize-points (coerce pp 'list)))
        
        ((atom pp) nil)                                      ; case c
        
        ((and (consp pp)                                     ; case d
              (numberp (car pp))         
              (numberp (cdr pp)))
         (list (make-pt :x (car pp) :y (cdr pp))))
        
        ((and (properlistp pp)                                ; case e
              (= (length pp) 2)
              (numberp (car pp))
              (numberp (cadr pp)))
         (list (make-pt :x (car pp) :y (cadr pp))))
             
        ((every #'pt-p pp) pp)                               ; case f
        
        ((every #'(lambda (p) (and (consp p)                 ; case g
                                   (numberp (car p))         
                                   (numberp (cdr p)))) pp)
         (mapcar #'(lambda (p) (make-pt :x (car p)
                                        :y (cdr p))) pp))
        
        ((every #'(lambda (p) (and (properlistp p)           ; case h
                                   (= (length p) 2)
                                   (numberp (car p))
                                   (numberp (cadr p)))) pp)
         (mapcar #'(lambda (p) (make-pt :x (car p)
                                        :y (cadr p))) pp))
        
        ((every #'(lambda (p) (and (vectorp p)               ; case i
                                   (= (length p) 2)
                                   (numberp (elt p 0))
                                   (numberp (elt p 1)))) pp)
         (mapcar #'(lambda (p) (make-pt :x (elt p 0)
                                        :y (elt p 1))) pp))
        
        ((and (> (length pp) 2) (every #'numberp pp))        ; case j
         (mapcar #'(lambda (x y) (make-pt :x x :y y))
                 (iota 0 (1- (length pp)) 1)
                 pp))
        
        ((= (length pp) 1)                                   ; case k
         (canonize-points (car pp)))
        
        (t nil)))                                            ; case l





;;;;;;;;;;;;;;;;;;;;;;;       GLYPHS       ;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;   a few examples   ;;;;;;;;;;;;;;;;;;;;;;;;;



;;; Generates glyph definitions for regular, convex polygons.


(defun regular-polygon-glyph (sides)
  (let* ((delta-theta (/ (* 2 pi) sides))
         (radius 0.5)
         (cmds nil))
    (push (list 'rotate 90) cmds)
    (push (list 'moveto radius 0.0) cmds)
    (nlet loop ((angle delta-theta) (count 1))
      (if (>= count sides)
        (nreverse (cons '(closepath) cmds))
        (let ((x (* radius (cos angle)))
              (y (* radius (sin angle))))
          (push (list 'lineto x y) cmds)
          (loop  (+ angle delta-theta)
                 (1+ count)))))))



;; Generate a star glyph -- a not-necessarily-convex polygon. The
;; parameter n is the number of sides and vertices. The parameter
;; k determines how the vertices are connected. Suppose we number
;; the vertices clockwise, from 0 to n-1. Then vertex j is always
;; connected to vertex (mod (+ j k) n). If k=1, then the result is
;; an ordinary, convex polygon. (star-glyph 5 2) produces the
;; familiar five-pointed star. But things get complicated when n
;; is divisible by k, because then we have k separate cycles,
;; each of length n/k. Thus the six-pointed mogen david is composed
;; of two equilateral triangles.

(defun star-glyph (n k)
  (let* ((delta-theta (/ (* 2 pi) n))
         (cycles (if (zerop (rem n k)) k 1))
         (sides-per-cycle (if (zerop (rem n k)) (/ n k) n))
         (radius 0.5)
         (cmds nil))
    (push (list 'rotate 90) cmds)
    (dotimes (c cycles)
      (push (list 'rotate (radians-to-degrees delta-theta)) cmds)
      (push (list 'moveto radius 0.0) cmds)
      (nlet loop ((angle (* k delta-theta)) (count 1))
            (if (>= count sides-per-cycle)
              (push '(closepath) cmds)
              (let ((x (* radius (cos angle)))
                    (y (* radius (sin angle))))
                (push (list 'lineto x y) cmds)
                (loop  (+ angle (* k delta-theta))
                       (1+ count))))))
    (nreverse cmds)))

;;; eof