home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / swat / scheme / demo-plotter.scm < prev    next >
Text File  |  2000-03-20  |  41KB  |  1,184 lines
  1. ;;; -*- Scheme -*-
  2.  
  3. (declare (usual-integrations))
  4.  
  5. ;;;; Plotting Package for Scheme Widget Application Toolkit
  6.  
  7. ;;; Working from the Scheme Prompt
  8.  
  9. ;;;(PLOTTER) 
  10. ;;;  Creates a new plotter.
  11. ;;; 
  12. ;;;     Example: (define p (plotter))
  13. ;;;
  14. ;;;(PLOT plotter . options)
  15. ;;;  The options list sequentially describes one or more curves to be
  16. ;;;  plotted, in the following manner: 
  17. ;;;
  18. ;;;    (PLOT plotter
  19. ;;;          <function1> '<option> <value> '<option> <value> ... ;first curve 
  20. ;;;          <function2> '<option> <value> ...                   ;second curve
  21. ;;;          ...
  22. ;;;          ...)
  23. ;;;  Returns a single curve if only one function is specified, and a
  24. ;;;  list of curves if more than one function is supplied.
  25. ;;;
  26. ;;;     Example: (define c0 (plot p sin 'xmin -10 'xmax 5))
  27. ;;;              (define c1&2 (plot p cos 'pt-style 0 tan 'pt-style 5))
  28. ;;;
  29. ;;;  The first parameter to PLOT after plotter must always be a
  30. ;;;  function. Curve-specific options affect only the function they
  31. ;;;  follow, and thus can and should be repeated.  Any instance of a
  32. ;;;  global option after the first will be ignored. 
  33. ;;;
  34. ;;;  Global options and arguments: 
  35. ;;;    'XMIN:  The minimum value of x to be displayed on the plot.
  36. ;;;            The default is 0. 
  37. ;;;    'XMAX:  The maximum value of x to be displayed on the plot.
  38. ;;;            The default is 1. 
  39. ;;;    'YMIN:  The minimum value of y to be displayed on the plot.
  40. ;;;            If not specified, the plot will be automatically scaled.
  41. ;;;    'YMAX:  The maximum value of y to be displayed on the plot.
  42. ;;;            If not specified, the plot will be automatically scaled.
  43. ;;;    'AXIS-X:  The value of x at which the y-axis will be drawn.
  44. ;;;              The default is 0. 
  45. ;;;    'AXIS-Y:  The value of y at which the x-axis will be drawn.
  46. ;;;              The default is 0. 
  47. ;;;    'XTICKS:  A list of pairs describing ticks on the x axis.  The
  48. ;;;              car of each pair is the value of x at which to make
  49. ;;;              the tick.  The cdr is a string to be displayed as a
  50. ;;;              label.  The procedure MAKE-VALS can be used to return
  51. ;;;              a list of values for labels at regular intervals. If
  52. ;;;              not specified, only the extreme values will be labeled. 
  53. ;;;    'YTICKS:  A list of pairs describing ticks on the y axis.  Same
  54. ;;;              format as XTICKS.  If not specified, only the extreme
  55. ;;;              values will be labeled. 
  56. ;;;
  57. ;;;  Curve-specific options and arguments
  58. ;;;    'NUM-PTS:  The number of points to be calculated for the curve.
  59. ;;;               The default is one for every 10 pixels.
  60. ;;;    'PT-STYLE:  A number representing the style in which the curve
  61. ;;;                will be drawn: 
  62. ;;;                  0  --  lines to the x-axis
  63. ;;;                  1  --  large unfilled circles
  64. ;;;                  2  --  large unfilled squares
  65. ;;;                  3  --  x's
  66. ;;;                  4  --  +'s
  67. ;;;                  5  --  small filled circles
  68. ;;;                  6  --  small filled squares
  69. ;;;                  7  --  dots
  70. ;;;                  10  --  large unfilled circles with lines to the x-axis
  71. ;;;                  20  --  large unfilled squares with lines to the x-axis
  72. ;;;                  30  --  x's with lines to the x-axis
  73. ;;;                  40  --  +'s with lines to the x-axis
  74. ;;;                  50  --  small filled circles with lines to the x-axis
  75. ;;;                  60  --  small filled squares with lines to the x-axis
  76. ;;;                  100  --  lines between successive points
  77. ;;;                The default for the first curve is 0, and for all
  78. ;;;                others 100. 
  79. ;;;    'COLOR:  The color of the curve, as a string or color-value.
  80. ;;;             The default for the first curve is black, and for all
  81. ;;;             others gray. 
  82. ;;;    'SHOW-VALS:  A list of values of x at which to label the
  83. ;;;                 corresponding value of y.  The procedure
  84. ;;;                 MAKE-VALS can be used to return a list of values
  85. ;;;                 at regular intervals.  The default is null.
  86. ;;;
  87. ;;;
  88. ;;;(SET-PLOTTER-PARAMS plotter '<option> <value> ... '<option> <value>)
  89. ;;;  Options are the same as global options in PLOT.  This does
  90. ;;;  basically the same thing as PLOT, but no *new* curve is drawn.
  91. ;;;  Parameters are reset and all the existing (non-cleared) curves
  92. ;;;  are redrawn.  Thus, an alternative way to write the example above
  93. ;;;  is: 
  94. ;;;
  95. ;;;     Example: (set-plotter-params p 'xmin -10 'xmax 5)
  96. ;;;              (define c0 (plot p sin))
  97. ;;;
  98. ;;;(RESET-PLOTTER-PARAMS plotter)
  99. ;;;  Resets plotter's parameters to default params (the ones you see
  100. ;;;  when the plotter first comes up).
  101. ;;;
  102. ;;;
  103. ;;;(MAKE-VALS min max spacing . centered?)
  104. ;;;  Returns a list of pairs that can be used for 'XTICKS 'YTICKS, or
  105. ;;;  'SHOW-VALS. If centered? is #t, the ticks will be centered about
  106. ;;;  0, with a tick at 0.  Otherwise, the ticks will begin at the min
  107. ;;;  value. 
  108. ;;; 
  109. ;;;     Example: (define c0 (plot p sin 'xmin -5 'xmax 5
  110. ;;;                                     'xticks (make-vals -5 5 1)))
  111. ;;;
  112. ;;;(CHANGE-COLOR curve color)
  113. ;;;  Changes the color of the given curve and replots the curve.
  114. ;;;  Replots the curve if it's not cleared.
  115. ;;;
  116. ;;;(CHANGE-PT-STYLE curve pt-style)
  117. ;;;  Changes the point style of the given curve and replots the curve.
  118. ;;;  Replots the curve if it's not cleared.
  119. ;;;
  120. ;;;(CHANGE-NUM-PTS curve num-pts)
  121. ;;;  Changes the number of points calculated for the given curve and
  122. ;;;  replots the curve. Replots the curve if it's not cleared.
  123. ;;;
  124. ;;;
  125. ;;;(CLEAR-CURVE curve)
  126. ;;;  Clears the given curve from the screen without deleting the curve
  127. ;;;  from the plotter.
  128. ;;;
  129. ;;;(PLOT-CURVE curve)
  130. ;;;  Replots the curve that has been cleared.
  131. ;;;
  132. ;;;(DELETE-CURVE curve)
  133. ;;;  Deletes the given curve from the plotter.
  134. ;;;
  135. ;;;(ADD-SHOW-VALS curve show-vals)
  136. ;;;  Add show-vals to a curve.
  137. ;;;
  138. ;;;(CLEAR-SHOW-VALS curve)
  139. ;;;  Clears all the curve's show vals, w/o deleting them from the curve.
  140. ;;;
  141. ;;;(DRAW-SHOW-VALS curve)
  142. ;;;  Redraws the cleared show-vals.
  143. ;;;
  144. ;;;(DELETE-SHOW-VALS curve)
  145. ;;;  Clears the curve's show-vals and deletes them from a curve.
  146. ;;;
  147. ;;;
  148. ;;;(ADD-XTICKS plotter xticks)
  149. ;;;  Adds the specified xticks.
  150. ;;;
  151. ;;;(ADD-YTICKS plotter yticks)
  152. ;;;  Adds the specified yticks.
  153. ;;;
  154. ;;;(CLEAR-TICKS plotter)
  155. ;;;  Clears ticks from the axes of the plotter, without deleting them
  156. ;;;  from the plotter.
  157. ;;;
  158. ;;;(DRAW-TICKS plotter)
  159. ;;;  Redraws the cleared ticks.
  160. ;;;
  161. ;;;(DELETE-TICKS plotter)
  162. ;;;  Clears ticks from the axes of the plotter and deletes them from
  163. ;;;  the plotter.
  164. ;;;
  165. ;;;
  166. ;;;(CLEAR-PLOTTER plotter)
  167. ;;;  Clears all plotter's curves and ticks.
  168. ;;;
  169. ;;;(REPLOT plotter)
  170. ;;;  Redraws all plotter's curves and ticks (including the cleared ones).
  171. ;;;
  172. ;;;(RESET-PLOTTER plotter)
  173. ;;;  Deletes all plotter's curves and ticks.
  174.  
  175.  
  176.  
  177. ;;;-------------------
  178. ;;; Interface Monster
  179. ;;;-------------------
  180.  
  181. ;;; Customizable Variables
  182.  
  183. (define button-background-color "yellow")
  184. (define button-active-background-color "red")
  185. (define button-active-foreground-color "white")
  186. (define canvas-background-color "white")
  187. (define canvas-width 500)
  188. (define canvas-height 300)
  189. (define canvas-border-size 15)
  190. (define font "-Adobe-Helvetica-Bold-R-Normal--*-100-*")
  191.  
  192. (define tick-precision 2)
  193. (define vals-precision 2)
  194.  
  195. (define curve-max-num-pts 200)
  196.  
  197. (define plotter-default-num-pts 50)
  198. (define plotter-default-pt-style 100)
  199. (define plotter-default-curve-color "black")
  200. (define plotter-default-xmin -5)
  201. (define plotter-default-xmax 5)
  202. (define plotter-default-ymin -1)
  203. (define plotter-default-ymax 1)
  204. (define plotter-default-axis-x 0)
  205. (define plotter-default-axis-y 0)
  206. (define plotter-default-xticks '())
  207. (define plotter-default-yticks '())
  208.  
  209.  
  210. (define (plotter)
  211.   (let* ((plot-app (make-application "Plotter"))
  212.      (plotter
  213.       (make-plot-canvas canvas-width canvas-height canvas-background-color))
  214.      (plot-canvas (plotter 'the-canvas))
  215.      (func-button (make-button '(-text "Function")))
  216.      (func-box #f)
  217.      (options-menu (make-menu))
  218.      (options-button (make-menubutton options-menu '(-text "Options")))
  219.      (precision (add-to-menu options-menu 'command '-label "Precision"))
  220.      (prec-box #f)
  221.      (range (add-to-menu options-menu 'command '-label "Range"))
  222.      (range-box #f)
  223.      (plot-button (make-button '(-text "Plot")))
  224.      (reset-button (make-button '(-text "Reset")))
  225.      (button-box (make-hbox func-button options-button plot-button reset-button))
  226.      (interface (make-vbox plot-canvas button-box)))
  227.  
  228.       (for-each (lambda (button)
  229.           (ask-widget
  230.            button
  231.            `(configure -background ,button-background-color
  232.                    -activebackground ,button-active-background-color
  233.                    -activeforeground ,button-active-foreground-color)))
  234.         (list func-button options-button plot-button reset-button))
  235.     
  236.       (for-each (lambda (button)
  237.           (ask-widget
  238.            button
  239.            `(configure -background ,button-background-color
  240.                    -activebackground ,button-background-color)))
  241.         (list range precision))
  242.     
  243.       (add-event-handler! plot-canvas "<Configure>" (plotter 'handle-resize))
  244.  
  245.       (set-callback!
  246.        func-button
  247.        (lambda ()
  248.      (if (not func-box)
  249.          (let ((new-func-box (make-func-box plot-app plotter)))
  250.            (on-death! new-func-box 'func-dead (lambda () (set! func-box #f)))
  251.            (set! func-box new-func-box)))))
  252.  
  253.       (set-callback!
  254.        precision
  255.        (lambda ()
  256.      (if (not prec-box)
  257.          (let ((new-prec-box (make-prec-box plot-app plotter)))
  258.            (on-death! new-prec-box 'prec-dead (lambda () (set! prec-box #f)))
  259.            (set! prec-box new-prec-box)))))
  260.  
  261.       (set-callback!
  262.        range
  263.        (lambda ()
  264.      (if (not range-box)
  265.          (let ((new-range-box (make-range-box plot-app plotter)))
  266.            (on-death! new-range-box 'range-dead (lambda () (set! range-box #f)))
  267.            (set! range-box new-range-box)))))
  268.  
  269.       (set-callback! plot-button (lambda () (plotter 'plot-current-func)))
  270.       (set-callback! reset-button (lambda () (plotter 'clear-curves)))
  271.  
  272.       (on-death! interface 'interface-dead 
  273.          (lambda ()
  274.            (if func-box  (remove-child! plot-app func-box))
  275.            (if range-box (remove-child! plot-app range-box))
  276.            (if prec-box  (remove-child! plot-app prec-box))))
  277.       
  278.       (swat-open-in-application plot-app interface)
  279.       plotter))
  280.  
  281. (define (make-func-box plot-app plotter)
  282.   (let* ((func-entry (make-entry `(-width 40 -background ,canvas-background-color)))
  283.      (func-ok-button
  284.       (make-button
  285.        `(-text "Ok" -background ,button-background-color
  286.          -activebackground ,button-active-background-color
  287.          -activeforeground ,button-active-foreground-color)))
  288.      (func-box (make-hbox func-entry func-ok-button)))
  289.     (define (function-callback)
  290.       (let ((exp (ask-widget func-entry '(get))))
  291.     (if (not (string-null? exp))
  292.         ;; Of course, this could get an error while evaling; maybe
  293.         ;; need something more clever.
  294.         (let ((proc (eval (with-input-from-string exp read)
  295.                   user-initial-environment)))
  296.           (if (not (procedure? proc))
  297.           (error "Not a procedure" proc)
  298.           ((plotter 'set-function) proc))))))
  299.     (add-event-handler! func-entry "<KeyPress> <Return>" function-callback)
  300.     (set-callback! func-ok-button function-callback)
  301.     (swat-open-in-application plot-app func-box '-title "Enter a function of x")
  302.     func-box))
  303.  
  304. (define (make-prec-box plot-app plotter)
  305.   (let* ((prec-scale
  306.       (make-scale `(-from 0 -to ,curve-max-num-pts -orient horizontal
  307.                 -length ,(inexact->exact (* 1.5 curve-max-num-pts))
  308.             -background ,canvas-background-color
  309.             -sliderforeground ,button-background-color
  310.             -activeforeground ,button-active-background-color)))
  311.      (prec-redraw
  312.       (make-button `(-text "Redraw Curves" -background ,button-background-color
  313.              -activebackground ,button-active-background-color
  314.              -activeforeground ,button-active-foreground-color)))
  315.      (prec-box (make-vbox prec-scale prec-redraw)))
  316.     (ask-widget prec-scale `(set ,(plotter 'default-num-pts)))
  317.     (add-event-handler!
  318.      prec-scale
  319.      "<ButtonRelease-1>"
  320.      (lambda ()
  321.        ((plotter 'set-default-num-pts)
  322.     (string->number (ask-widget prec-scale '(get))))))
  323.     (set-callback! prec-redraw (lambda () (plotter 'plot-curves)))
  324.     (swat-open-in-application plot-app prec-box '-title "Number of points:")
  325.     prec-box))
  326.  
  327. (define (make-range-box plot-app plotter)
  328.   (let* ((range-ok-button
  329.       (make-button `(-text "Ok" -background ,button-background-color
  330.              -activebackground ,button-active-background-color
  331.              -activeforeground ,button-active-foreground-color)))
  332.      (xmin-text (make-active-variable plot-app))
  333.      (xmax-text (make-active-variable plot-app))
  334.      (ymin-text (make-active-variable plot-app))
  335.      (ymax-text (make-active-variable plot-app))
  336.      (xmin-entry (make-entry `(-textvariable ,xmin-text)))
  337.      (xmax-entry (make-entry `(-textvariable ,xmax-text)))
  338.      (ymin-entry (make-entry `(-textvariable ,ymin-text)))
  339.      (ymax-entry (make-entry `(-textvariable ,ymax-text)))
  340.      (x-label (make-label '(-text "Values of x:")))
  341.      (xmin-label (make-label '(-text "From")))
  342.      (xmax-label (make-label '(-text "To")))
  343.      (y-label (make-label '(-text "Values of y:")))
  344.      (ymin-label (make-label '(-text "From")))
  345.      (ymax-label (make-label '(-text "To")))
  346.      (x-box
  347.       (make-vbox x-label
  348.              (make-hbox xmin-label xmin-entry xmax-label xmax-entry)))
  349.      (y-box
  350.       (make-vbox y-label
  351.              (make-hbox ymin-label ymin-entry ymax-label ymax-entry)))
  352.      (range-box (make-hbox (make-vbox x-box y-box) range-ok-button)))
  353.     (for-each (lambda (label)
  354.         (ask-widget label `(configure -background ,canvas-background-color)))
  355.           (list x-label xmin-label xmax-label y-label ymin-label ymax-label))
  356.     (for-each (lambda (entry)
  357.         ;; background color?
  358.         (ask-widget entry `(configure -width 5)))
  359.           (list xmin-entry xmax-entry ymin-entry ymax-entry))
  360.     (set-callback!
  361.      range-ok-button
  362.      (lambda ()
  363.        (let ((xmin (plotter 'xmin))
  364.          (xmax (plotter 'xmax))
  365.          (ymin (plotter 'ymin))
  366.          (ymax (plotter 'ymax))
  367.          (new-xmin (string->number (ask-widget xmin-entry '(get))))
  368.          (new-xmax (string->number (ask-widget xmax-entry '(get))))
  369.          (new-ymin (string->number (ask-widget ymin-entry '(get))))
  370.          (new-ymax (string->number (ask-widget ymax-entry '(get)))))
  371.      (if (not (and (eqv? xmin new-xmin)
  372.                (eqv? xmax new-xmax)
  373.                (eqv? ymin new-ymin)
  374.                (eqv? ymax new-ymax)))
  375.          (begin
  376.            ((plotter 'set-xmin) new-xmin)
  377.            ((plotter 'set-xmax) new-xmax)
  378.            ((plotter 'set-ymin) new-ymin)
  379.            ((plotter 'set-ymax) new-ymax)
  380.            (plotter 'clear)
  381.            (draw-axes plotter)
  382.            (plotter 'plot-curves))))))
  383.     (swat-open-in-application plot-app range-box '-title "Range")
  384.     (set-active-variable! xmin-text (plotter 'xmin))
  385.     (set-active-variable! xmax-text (plotter 'xmax))
  386.     (set-active-variable! ymin-text (plotter 'ymin))
  387.     (set-active-variable! ymax-text (plotter 'ymax))
  388.     range-box))
  389.  
  390.  
  391. ;;;-------------
  392. ;;; The Plotter
  393. ;;;-------------
  394.  
  395. (define (make-plot-canvas hsize vsize bgrnd-color)
  396.   (let ((default-num-pts plotter-default-num-pts)
  397.     (default-pt-style plotter-default-pt-style)
  398.     (default-color plotter-default-curve-color)
  399.     (xmin plotter-default-xmin)
  400.     (xmax plotter-default-xmax)
  401.     (ymin plotter-default-ymin)
  402.     (ymax plotter-default-ymax)
  403.     (yaxis.xval plotter-default-axis-x)
  404.     (xaxis.yval plotter-default-axis-y)
  405.     (xticks plotter-default-xticks)
  406.     (yticks plotter-default-yticks)
  407.     (current-func #f)
  408.     (current-func-curve #f)
  409.     (curve-list '())
  410.     (resize-flag #f))
  411.     (let* ((the-canvas (make-canvas `(-width ,hsize -height ,vsize
  412.                       -background ,bgrnd-color)))
  413.        (axes-tag (make-canvas-item-group the-canvas '()))
  414.        (ticks-tag (make-canvas-item-group the-canvas '())))
  415.       (define (plotter messg)
  416.     (case messg
  417.       ((hsize) hsize)
  418.       ((vsize) vsize)
  419.       ((the-canvas) the-canvas)
  420.       ((curve-list) curve-list)
  421.       ((default-num-pts) default-num-pts)
  422.       ((set-default-num-pts)
  423.        (lambda (new-num-pts) (set! default-num-pts new-num-pts)))
  424.       ((default-pt-style) default-pt-style)
  425.       ((set-default-pt-style)
  426.        (lambda (new-pt-style) (set! default-pt-style new-pt-style)))
  427.       ((default-color) default-color)
  428.       ((set-default-color)
  429.        (lambda (new-color) (set! default-color new-color)))
  430.       ((function) current-func)
  431.       ((set-function)
  432.        (lambda (func)
  433.          (set! current-func-curve #f)
  434.          (set! current-func func)))
  435.       ((xmin) xmin)
  436.       ((set-xmin) (lambda (new-xmin) (set! xmin new-xmin)))
  437.       ((xmax) xmax)
  438.       ((set-xmax) (lambda (new-xmax) (set! xmax new-xmax)))
  439.       ((ymin) ymin)
  440.       ((set-ymin) (lambda (new-ymin) (set! ymin new-ymin)))
  441.       ((ymax) ymax)
  442.       ((set-ymax) (lambda (new-ymax) (set! ymax new-ymax)))
  443.       ((xaxis.yval) xaxis.yval)
  444.       ((yaxis.xval) yaxis.xval)
  445.       ((xaxis.y)
  446.        (let ((y-range (- ymax ymin)))
  447.          (if (= y-range 0)
  448.          (error "ymin and ymax are the same--MAKE-PLOT-CANVAS" ymin)
  449.          (+ (* (exact->inexact (/ (- (* canvas-border-size 2) vsize)
  450.                       y-range))
  451.                (- xaxis.yval ymin))
  452.             vsize
  453.             (- canvas-border-size)))))
  454.       ((yaxis.x)
  455.        (let ((x-range (- xmax xmin)))
  456.          (if (= x-range 0)
  457.          (error "xmin and xmax are the same--MAKE-PLOT-CANVAS" xmin)
  458.          (+ (* (exact->inexact (/ (- hsize (* canvas-border-size 2))
  459.                       (- xmax xmin)))
  460.                (- yaxis.xval xmin))
  461.             canvas-border-size))))
  462.       ((xticks) xticks)
  463.       ((set-xticks) (lambda (new-xticks) (set! xticks new-xticks)))
  464.       ((yticks) yticks)
  465.       ((set-yticks) (lambda (new-yticks) (set! yticks new-yticks)))
  466.       ((axes-tag) axes-tag)
  467.       ((ticks-tag) ticks-tag)
  468.       ((set-params)
  469.        (lambda (new-xmin new-xmax new-ymin new-ymax
  470.                  new-yaxis.xval new-xaxis.yval new-xticks new-yticks)
  471.          (set! xmin new-xmin)
  472.          (set! xmax new-xmax)
  473.          (set! ymin new-ymin)
  474.          (set! ymax new-ymax)
  475.          (set! yaxis.xval new-yaxis.xval)
  476.          (set! xaxis.yval new-xaxis.yval)
  477.          (set! xticks new-xticks)
  478.          (set! yticks new-yticks)
  479.          'set))
  480.       ((x:val->pix) (x:val->pix xmin xmax hsize))
  481.       ((y:val->pix) (y:val->pix ymin ymax vsize))
  482.       ((add-curve)
  483.        (lambda (curve) (set! curve-list (append curve-list (list curve)))))
  484.       ((plot-current-func)
  485.        (if (and current-func (not current-func-curve))
  486.            (let ((new-curve
  487.               (make-curve plotter current-func default-pt-style
  488.                   default-num-pts default-color #f)))
  489.          (set! current-func-curve new-curve)
  490.          (set! curve-list (cons new-curve curve-list))
  491.          (new-curve 'plot))))
  492.       ((plot-curves)
  493.        (for-each (lambda (curve)
  494.                (if (not (curve 'cleared?))
  495.                (curve 'plot)))
  496.              curve-list)
  497.        'plotted)
  498.       ((clear)
  499.        (ask-widget the-canvas '(delete all))
  500.        'cleared)
  501.       ((clear-curves)
  502.        (for-each (lambda (curve) (curve 'clear)) curve-list)
  503.        'cleared)
  504.       ((delete-curve)
  505.        (lambda (curve)
  506.          (curve 'clear)
  507.          (set! curve-list (delq curve curve-list))
  508.          'deleted))
  509.       ((delete-curves)
  510.        (for-each (lambda (curve) (curve 'clear)) curve-list)
  511.        (set! curve-list #f)
  512.        'deleted)
  513.       ((clear-axes)
  514.        (ask-widget axes-tag '(delete))
  515.        'cleared)
  516.       ((clear-ticks)
  517.        (ask-widget ticks-tag '(delete))
  518.        'cleared)
  519.       ((delete-ticks)
  520.        (set! xticks '())
  521.        (set! yticks '())
  522.        (ask-widget ticks-tag '(delete))
  523.        'deleted)
  524.       ((handle-resize)
  525.        (lambda ()
  526.          ;; For some reason, the "<Configure>" event gets generated
  527.          ;; twice per window resize -- so skip one of them.
  528.          (if (not resize-flag)
  529.          (set! resize-flag #t)
  530.          (begin
  531.            (set! resize-flag #f)
  532.            (ask-widget the-canvas '(delete all))
  533.            (let ((old-width hsize)
  534.              (width (UITKRectangle.width
  535.                  (assigned-screen-area the-canvas)))
  536.              (height (UITKRectangle.height
  537.                   (assigned-screen-area the-canvas))))
  538.              (set! hsize width)
  539.              (set! vsize height)
  540.              (set! default-num-pts (round (* default-num-pts
  541.                              (/ width old-width))))
  542.              (draw-axes plotter)
  543.              (for-each
  544.               (lambda (curve)
  545.             (curve-scale-num-pts!
  546.              curve (exact->inexact (/ width old-width)))
  547.             (if (not (curve 'cleared?))
  548.                 (begin (curve 'clear)
  549.                    (curve 'plot))))
  550.               curve-list))))))
  551.       (else (error "Bad message--PLOTTER" messg))))
  552.       plotter)))
  553.  
  554. (define ((x:val->pix xmin xmax hsize) x)
  555.   (+ (* (exact->inexact
  556.      (/ (- hsize (* canvas-border-size 2))
  557.         (- xmax xmin)))
  558.     (- x xmin))
  559.      canvas-border-size))
  560.  
  561. (define ((y:val->pix ymin ymax vsize) y)
  562.   (+ (* (exact->inexact
  563.      (/ (- (* canvas-border-size 2) vsize)
  564.         (- ymax ymin)))
  565.     (- y ymin))
  566.      vsize
  567.      (- canvas-border-size)))
  568.  
  569. (define (draw-xticks plotter)
  570.   (let ((xticks (plotter 'xticks)))
  571.     (if xticks
  572.     (let ((plot-canvas (plotter 'the-canvas))
  573.           (x:val->pix (plotter 'x:val->pix))
  574.           (xmin (plotter 'xmin))
  575.           (xmax (plotter 'xmax))
  576.           (xaxis.y (plotter 'xaxis.y))
  577.           (ticks-tag (plotter 'ticks-tag))
  578.           (factor (expt 10 tick-precision)))
  579.       (for-each
  580.        (lambda (tick)
  581.          (if (> xmax tick xmin)
  582.          (let ((val (x:val->pix tick))
  583.                (tag (swat:number->string
  584.                  (/ (truncate (* factor tick)) factor))))
  585.            (add-to-canvas-item-group
  586.             ticks-tag
  587.             (make-line-on-canvas plot-canvas
  588.                      val (- xaxis.y 4)
  589.                      val (+ xaxis.y 4)))
  590.            (add-to-canvas-item-group
  591.             ticks-tag
  592.             (make-text-on-canvas plot-canvas
  593.                      val (- xaxis.y 9)
  594.                      `(-text ,tag -font ,font))))))
  595.        xticks))))
  596.   'drawn)
  597.  
  598. (define (draw-yticks plotter)
  599.   (let ((yticks (plotter 'yticks)))
  600.     (if yticks
  601.     (let ((plot-canvas (plotter 'the-canvas))
  602.           (y:val->pix (plotter 'y:val->pix))
  603.           (ymin (plotter 'ymin))
  604.           (ymax (plotter 'ymax))
  605.           (yaxis.x (plotter 'yaxis.x))
  606.           (ticks-tag (plotter 'ticks-tag))
  607.           (factor (expt 10 tick-precision)))
  608.       (for-each
  609.        (lambda (tick)
  610.          (if (> ymax tick ymin)
  611.          (let ((val (y:val->pix tick))
  612.                (tag (swat:number->string
  613.                  (/ (truncate (* factor tick)) factor))))
  614.            (add-to-canvas-item-group
  615.             ticks-tag
  616.             (make-line-on-canvas plot-canvas
  617.                      (- yaxis.x 4) val
  618.                      (+ yaxis.x 4) val))
  619.            (add-to-canvas-item-group
  620.             ticks-tag
  621.             (make-text-on-canvas plot-canvas
  622.                      (+ yaxis.x 6) val
  623.                      `(-text ,tag -anchor w
  624.                          -font ,font))))))
  625.        yticks))))
  626.   'drawn)
  627.  
  628. (define (draw-axes plotter)
  629.   (let* ((plot-canvas (plotter 'the-canvas))
  630.      (hsize (plotter 'hsize))
  631.      (vsize (plotter 'vsize))
  632.      (xmin  (plotter 'xmin))
  633.      (xmax  (plotter 'xmax))
  634.      (ymin  (plotter 'ymin))
  635.      (ymax  (plotter 'ymax))
  636.      (xaxis.yval (plotter 'xaxis.yval))
  637.      (yaxis.xval (plotter 'yaxis.xval))
  638.      (xaxis.y (plotter 'xaxis.y))
  639.      (yaxis.x (plotter 'yaxis.x))
  640.      (axes-tag (plotter 'axes-tag))
  641.      (trim 3)
  642.      (x-.x trim)
  643.      (x+.x (- hsize trim))
  644.      (y-.y trim)
  645.      (y+.y (- vsize trim)))
  646.     (if (>= ymax xaxis.yval ymin)
  647.     (begin
  648.       (add-to-canvas-item-group
  649.        axes-tag
  650.        (make-line-on-canvas plot-canvas x+.x xaxis.y x-.x xaxis.y '(-arrow both)))
  651.       (draw-xticks plotter)
  652.       (make-text-on-canvas plot-canvas
  653.                    (- hsize trim) (- xaxis.y trim)
  654.                    `(-text ,(swat:number->string xmax) -anchor se)) ;
  655.       (make-text-on-canvas plot-canvas
  656.                    trim (- xaxis.y trim)
  657.                    `(-text ,(swat:number->string xmin) -anchor sw))))
  658.     (if (>= xmax yaxis.xval xmin)
  659.     (begin
  660.       (add-to-canvas-item-group
  661.        axes-tag
  662.        (make-line-on-canvas plot-canvas yaxis.x y+.y yaxis.x y-.y '(-arrow both)))
  663.       (draw-yticks plotter)
  664.       (let ((factor (expt 10 tick-precision)))
  665.         (make-text-on-canvas plot-canvas
  666.                  (+ yaxis.x 8) trim
  667.                  `(-text ,(swat:number->string
  668.                        (/ (round (* ymax factor)) factor))
  669.                      -anchor nw))
  670.         (make-text-on-canvas plot-canvas
  671.                  (+ yaxis.x 8) vsize
  672.                  `(-text ,(swat:number->string
  673.                        (/ (round (* ymin factor)) factor))
  674.                      -anchor sw)))))
  675.     'done))
  676.  
  677. ;;;--------
  678. ;;; Curves
  679. ;;;--------
  680.  
  681. (define (make-curve plotter function pt-style num-pts color show-vals)
  682.   (let* ((plot-canvas (plotter 'the-canvas))
  683.      (curve-tag (make-canvas-item-group plot-canvas '()))
  684.      (outline-tag (make-canvas-item-group plot-canvas '()))
  685.      (vals-tag (make-canvas-item-group plot-canvas '()))
  686.      (cleared? #f))
  687.     (lambda (messg)
  688.       (case messg
  689.     ((plotter) plotter)
  690.     ((num-pts) num-pts)
  691.     ((set-num-pts) (lambda (new-num-pts) (set! num-pts new-num-pts)))
  692.     ((show-vals) show-vals)
  693.     ((set-show-vals) (lambda (new-vals) (set! show-vals new-vals)))
  694.     ((cleared?) cleared?)
  695.     ((change-pt-style)
  696.      (lambda (new-pt-style)
  697.        (cond ((pt-style? new-pt-style)
  698.           (set! pt-style new-pt-style))
  699.          (else (write-line "Not a style--MAKE-CURVE") pt-style))))
  700.     ((change-color)
  701.      (lambda (new-color)
  702.        (set! color new-color)
  703.        (if (not cleared?)
  704.            (begin
  705.          (ask-widget curve-tag `(configure -fill ,color))
  706.          (ask-widget outline-tag `(configure -outline ,color))
  707.          (ask-widget vals-tag `(configure -fill ,color))))))
  708.     ((get-extreme-vals)
  709.      (lambda (min max)
  710.        (get-extreme-vals function min max num-pts)))
  711.     ((plot)
  712.      (graph function plotter curve-tag outline-tag pt-style num-pts color)
  713.      (if show-vals
  714.          (graph-vals function plotter show-vals vals-tag color))
  715.      (set! cleared? #f)
  716.      'plotted)
  717.     ((draw-vals)
  718.      (if show-vals
  719.          (graph-vals function plotter show-vals vals-tag color))
  720.      'drawn)
  721.     ((clear-vals)
  722.      (ask-widget vals-tag '(delete))
  723.      'cleared)
  724.     ((delete-vals)
  725.      (ask-widget vals-tag '(delete))
  726.      (set! show-vals #f)
  727.      'removed)
  728.     ((clear)
  729.      (ask-widget curve-tag '(delete))
  730.      (ask-widget outline-tag '(delete))
  731.      (ask-widget vals-tag '(delete))
  732.      (set! cleared? #t)
  733.      'cleared)
  734.     (else (error "Bad message--MAKE-CURVE" messg))))))
  735.  
  736. (define (get-extreme-vals function min max num-pts)
  737.   (let* ((factor (expt 10 vals-precision))
  738.      (first-val (function min))
  739.      (min-val first-val)
  740.      (max-val first-val)
  741.      (step (exact->inexact (/ (- max min) num-pts))))
  742.     (define (calculate x)
  743.       (let ((val (function x)))
  744.     (cond ((> x max)
  745.            (list (/ (round (* min-val factor)) factor)
  746.              (/ (round (* max-val factor)) factor)))
  747.           ((< val min-val) (set! min-val val)
  748.                    (calculate (+ x step)))
  749.           ((> val max-val) (set! max-val val)
  750.                    (calculate (+ x step)))
  751.           (else (calculate (+ x step))))))
  752.     (calculate (+ min step))))
  753.  
  754. (define (pt-style? val)
  755.   (memv val '(0 1 2 3 4 5 6 7 10 20 30 40 50 60 100)))
  756.  
  757. (define (curve-scale-num-pts! curve factor)
  758.   ((curve 'set-num-pts) (round (* (curve 'num-pts) factor))))
  759.  
  760. (define (maybe-replot-curve curve)
  761.   (if (not (curve 'cleared?))
  762.       (begin (curve 'clear)
  763.          (curve'plot))))
  764.  
  765. (define (graph function plotter curve-tag outline-tag pt-style num-pts color)
  766.   (let ((plot-canvas (plotter 'the-canvas))
  767.     (xmin (plotter 'xmin))
  768.     (xmax (plotter 'xmax))
  769.     (xaxis.yval (plotter 'xaxis.yval))
  770.     (x:val->pix (plotter 'x:val->pix))
  771.     (y:val->pix (plotter 'y:val->pix)))
  772.     (let ((xaxis.y (y:val->pix xaxis.yval)))
  773.  
  774.       (define (draw-0 x y)
  775.       (add-to-canvas-item-group
  776.        curve-tag (make-line-on-canvas plot-canvas x xaxis.y x y)))
  777.       (define (draw-1 x y)
  778.     (add-to-canvas-item-group
  779.      outline-tag
  780.      (make-oval-on-canvas plot-canvas (- x 3) (- y 3) (+ x 3) (+ y 3))))
  781.       (define (draw-2 x y)
  782.     (add-to-canvas-item-group
  783.      outline-tag 
  784.      (make-rectangle-on-canvas plot-canvas (- x 3) (- y 3) (+ x 3) (+ y 3))))
  785.       (define (draw-3 x y)
  786.     (add-to-canvas-item-group
  787.      curve-tag 
  788.      (make-line-on-canvas plot-canvas (- x 2) (- y 2) (+ x 3) (+ y 3)))
  789.     (add-to-canvas-item-group
  790.      curve-tag
  791.      (make-line-on-canvas plot-canvas (+ x 2) (- y 2) (- x 2) (+ y 2))))
  792.       (define (draw-4 x y)
  793.     (add-to-canvas-item-group
  794.      curve-tag (make-line-on-canvas plot-canvas x (- y 2) x (+ y 3)))
  795.     (add-to-canvas-item-group
  796.      curve-tag (make-line-on-canvas plot-canvas (- x 2) y (+ x 3) y)))
  797.       (define (draw-5 x y)
  798.     (let ((seg (make-oval-on-canvas plot-canvas
  799.                     (- x 2) (- y 2) (+ x 2) (+ y 2))))
  800.       (add-to-canvas-item-group curve-tag seg)
  801.       (add-to-canvas-item-group outline-tag seg)))
  802.       (define (draw-6 x y)
  803.     (let ((seg (make-rectangle-on-canvas plot-canvas
  804.                          (- x 2) (- y 2) (+ x 2) (+ y 2))))
  805.       (add-to-canvas-item-group curve-tag seg)
  806.       (add-to-canvas-item-group outline-tag seg)))
  807.       (define (draw-7 x y)
  808.     (add-to-canvas-item-group
  809.      curve-tag (make-text-on-canvas plot-canvas x (- y 2) '(-text "."))))
  810.       (define (draw-10 x y)
  811.     (add-to-canvas-item-group
  812.      curve-tag (make-line-on-canvas plot-canvas x xaxis.y x (+ y 3)))
  813.     (add-to-canvas-item-group
  814.      outline-tag (make-oval-on-canvas
  815.               plot-canvas (- x 3) (- y 3) (+ x 3) (+ y 3))))
  816.       (define (draw-20 x y)
  817.     (add-to-canvas-item-group
  818.      curve-tag (make-line-on-canvas plot-canvas x xaxis.y x (+ y 2)))
  819.     (add-to-canvas-item-group
  820.      outline-tag
  821.      (make-rectangle-on-canvas plot-canvas
  822.                    (- x 3) (- y 3) (+ x 3) (+ y 3))))
  823.       (define (draw-30 x y)
  824.     (add-to-canvas-item-group
  825.      curve-tag (make-line-on-canvas plot-canvas
  826.                      (- x 2) (- y 2) (+ x 3) (+ y 3)))
  827.     (add-to-canvas-item-group
  828.      curve-tag (make-line-on-canvas plot-canvas
  829.                      (+ x 2) (- y 2) (- x 2) (+ y 2)))
  830.     (add-to-canvas-item-group
  831.      curve-tag (make-line-on-canvas plot-canvas x xaxis.y x y)))
  832.       (define (draw-40 x y)
  833.     (add-to-canvas-item-group
  834.      curve-tag (make-line-on-canvas plot-canvas x (- y 2) x xaxis.y))
  835.     (add-to-canvas-item-group
  836.      curve-tag (make-line-on-canvas plot-canvas (- x 2) y (+ x 3) y)))
  837.       (define (draw-50 x y)
  838.     (let ((seg1 (make-oval-on-canvas plot-canvas
  839.                      (- x 2) (- y 2) (+ x 2) (+ y 2)))
  840.           (seg2 (make-line-on-canvas plot-canvas x xaxis.y x (+ y 2))))
  841.       (add-to-canvas-item-group outline-tag seg1)
  842.       (add-to-canvas-item-group curve-tag seg1)
  843.       (add-to-canvas-item-group curve-tag seg2)))
  844.       (define (draw-60 x y)
  845.     (let ((seg1 (make-rectangle-on-canvas plot-canvas
  846.                           (- x 2) (- y 2) (+ x 2) (+ y 2)))
  847.           (seg2 (make-line-on-canvas plot-canvas x xaxis.y x (+ y 2))))
  848.       (add-to-canvas-item-group outline-tag seg1)
  849.       (add-to-canvas-item-group curve-tag seg1)
  850.       (add-to-canvas-item-group curve-tag seg2)))
  851.  
  852.       (define (draw-dispatch pt-style)
  853.     (cond ((= pt-style 0) draw-0)
  854.           ((= pt-style 1) draw-1)
  855.           ((= pt-style 2) draw-2)
  856.           ((= pt-style 3) draw-3)
  857.           ((= pt-style 4) draw-4)
  858.           ((= pt-style 5) draw-5)
  859.           ((= pt-style 6) draw-6)
  860.           ((= pt-style 7) draw-7)
  861.           ((= pt-style 10) draw-10)
  862.           ((= pt-style 20) draw-20)
  863.           ((= pt-style 30) draw-30)
  864.           ((= pt-style 40) draw-40)
  865.           ((= pt-style 50) draw-50)
  866.           ((= pt-style 60) draw-60)))
  867.  
  868.       (let* ((draw (draw-dispatch pt-style))
  869.          (xstep (exact->inexact (/ (- xmax xmin) num-pts))))
  870.     (define (calc-100 last-x last-y x y)
  871.       (if (not (> x xmax))
  872.           (let ((segment
  873.              (make-line-on-canvas plot-canvas
  874.                       (x:val->pix last-x)
  875.                       (y:val->pix last-y)
  876.                       (x:val->pix x)
  877.                       (y:val->pix y))))
  878.         (add-to-canvas-item-group curve-tag segment)
  879.         (calc-100 x y (+ x xstep) (function (+ x xstep))))))
  880.     (define (calculate x y)
  881.       (if (not (> x xmax))
  882.           (begin (draw (x:val->pix x) (y:val->pix y))
  883.              (calculate (+ x xstep) (function (+ x xstep))))))
  884.  
  885.     (if (= pt-style 100)
  886.         (calc-100 xmin (function xmin) (+ xmin xstep) (function (+ xmin xstep)))
  887.         (calculate xmin (function xmin)))
  888.     (ask-widget curve-tag `(configure -fill ,color))
  889.     (ask-widget outline-tag `(configure -outline ,color))))))
  890.  
  891. (define (graph-vals function plotter show-vals vals-tag color)
  892.   (let ((factor (expt 10 vals-precision))
  893.     (x:val->pix (plotter 'x:val->pix))
  894.     (y:val->pix (plotter 'y:val->pix))
  895.     (plot-canvas (plotter 'the-canvas)))
  896.     (let marker ((show-vals show-vals))
  897.       (if (not (null? show-vals))
  898.       (let* ((x-val (car show-vals))
  899.          (x (x:val->pix x-val))
  900.          (y-val (function x-val))
  901.          (y (y:val->pix y-val))
  902.          (pos-y? (>= y-val (plotter 'xaxis.yval))))
  903.         (add-to-canvas-item-group
  904.          vals-tag
  905.          (make-text-on-canvas
  906.           plot-canvas x (if pos-y? (- y 3) (+ y 6))
  907.           `(-text ,(swat:number->string (/ (round (* y-val factor)) factor))
  908.         -anchor ,(if pos-y? 's 'n))))
  909.         (add-to-canvas-item-group
  910.          vals-tag
  911.          (make-text-on-canvas plot-canvas x y '(-text "|")))
  912.         (marker (cdr show-vals)))))
  913.     (ask-widget vals-tag `(configure -fill ,color))))
  914.  
  915.  
  916. ;;;-------------------------
  917. ;;; Scheme-prompt Interface
  918. ;;;-------------------------
  919.  
  920. (define (plot plotter . spec-list)
  921.   (define (package-curves arg-list)
  922.     (let package-loop ((result (list (car arg-list)))
  923.                (rest (cdr arg-list)))
  924.       (cond ((null? rest) (list (reverse result)))
  925.         ((procedure? (car rest))
  926.          (cons (reverse result) (package-curves rest)))
  927.         (else (package-loop (cons (car rest) result) (cdr rest))))))
  928.   (if (not (null? spec-list))
  929.       (let* ((curve-desc-list (package-curves spec-list))
  930.          (old-xmin (plotter 'xmin))
  931.          (old-xmax (plotter 'xmax))
  932.          (old-ymin (plotter 'ymin))
  933.          (old-ymax (plotter 'ymax))
  934.          (old-axis-y (plotter 'xaxis.yval))
  935.          (old-axis-x (plotter 'yaxis.xval))
  936.          (old-xticks (plotter 'xticks))
  937.          (old-yticks (plotter 'yticks))
  938.          (xmin~ #f) (axis-x~ #f) (num-pts~ #f)
  939.          (xmax~ #f) (axis-y~ #f) (pt-style~ #f) 
  940.          (ymin~ #f) (xticks~ #f) (color~ #f)
  941.          (ymax~ #f) (yticks~ #f) (show-vals~ #f)
  942.          (default-num-pts  (plotter 'default-num-pts))
  943.          (default-pt-style (plotter 'default-pt-style))
  944.          (default-color    (plotter 'default-color))
  945.          (curve-list '()))
  946.  
  947.     (define (process-next-curve curve-desc)
  948.       (let ((f (car curve-desc))
  949.         (curve-options (cdr curve-desc)))
  950.         (let curve-loop ((curve-options curve-options))
  951.           (if (not (null? curve-options))
  952.           (let ((option-name (car curve-options)))
  953.             (cond ((not (symbol? option-name))
  954.                (error "Bad option--PLOT" option-name))
  955.               ((null? (cdr curve-options))
  956.                (error "PLOT: No value specified for option"
  957.                   option-name))
  958.               (else
  959.                (let ((option-value (cadr curve-options)))
  960.                  (process-option option-name option-value)
  961.                  (curve-loop (cddr curve-options))))))))
  962.         (make-curve plotter
  963.             f
  964.             (or pt-style~ default-pt-style)
  965.             (or num-pts~ default-num-pts)
  966.             (or color~ default-color)
  967.             show-vals~)))
  968.  
  969.     (define (process-option name value)
  970.       (case name
  971.         ;; global options
  972.         ((xmin) (if (not xmin~) (set! xmin~ value)))
  973.         ((xmax) (if (not xmax~) (set! xmax~ value)))
  974.         ((ymin) (if (not ymin~) (set! ymin~ value)))
  975.         ((ymax) (if (not ymax~) (set! ymax~ value)))
  976.         ((axis-x) (if (not axis-x~) (set! axis-x~ value)))
  977.         ((axis-y) (if (not axis-y~) (set! axis-y~ value)))
  978.         ((xticks) (if (not xticks~) (set! xticks~ value)))
  979.         ((yticks) (if (not yticks~) (set! xticks~ value)))
  980.         ;; curve-specific options
  981.         ((num-pts) (set! num-pts~ value))
  982.         ((pt-style) (set! pt-style~ value))
  983.         ((color) (set! color~ value))
  984.         ((show-vals) (set! show-vals~ value))
  985.         (else (error "Illegal option--PLOT" name))))
  986.  
  987.     (define (reset-options!)
  988.       (set! num-pts~ #f)
  989.       (set! pt-style~ #f)
  990.       (set! color~ #f)
  991.       (set! show-vals~ #f))
  992.  
  993.       (let process-loop ((curve-desc-list (reverse curve-desc-list)))
  994.         (if (not (null? curve-desc-list))
  995.         (let ((new-curve (process-next-curve (car curve-desc-list))))
  996.           ((plotter 'add-curve) new-curve)
  997.           (set! curve-list (cons new-curve curve-list))
  998.           (reset-options!)
  999.           (process-loop (cdr curve-desc-list)))))
  1000.     
  1001.       (let* ((xmin (or xmin~ old-xmin))
  1002.          (xmax (or xmax~ old-xmax))
  1003.          (get-extremes
  1004.           (lambda (xmin xmax)
  1005.             (map (lambda (curve) ((curve 'get-extreme-vals) xmin xmax))
  1006.              curve-list)))
  1007.          (extremes #f)
  1008.          (ymin
  1009.           (or ymin~
  1010.               (min
  1011.                old-ymin
  1012.                (let ((xtremes (get-extremes xmin xmax)))
  1013.              (set! extremes xtremes)
  1014.              (apply min (cons 0 (map (lambda (e) (car e)) xtremes)))))))
  1015.          (ymax
  1016.           (or ymax~
  1017.               (max
  1018.                old-ymax
  1019.                (let ((xtremes
  1020.                   (if extremes extremes (get-extremes xmin xmax))))
  1021.              (apply max (cons 0 (map (lambda (e) (cadr e)) xtremes)))))))
  1022.          (axis-y (or axis-y~ old-axis-y))
  1023.          (axis-x (or axis-x~ old-axis-x)))
  1024.  
  1025.         (if (and (= xmin old-xmin)
  1026.              (= xmax old-xmax)
  1027.              (= ymin old-ymin)
  1028.              (= ymax old-ymax)
  1029.              (= axis-x old-axis-x)
  1030.              (= axis-y old-axis-y)
  1031.              (equal? xticks~ old-xticks)
  1032.              (equal? yticks~ old-yticks))
  1033.         ;; only plot the new curves
  1034.         (for-each (lambda (new-curve) (new-curve 'plot))
  1035.               curve-list)
  1036.             ;; if a global param changed, replot everything
  1037.         (begin
  1038.           ((plotter 'set-params)
  1039.            xmin xmax ymin ymax axis-x axis-y xticks~ yticks~)
  1040.           (plotter 'clear)
  1041.           (draw-axes plotter)
  1042.           (plotter 'plot-curves)))
  1043.         
  1044.         ;; return the curve if there's only one, list of curves if more.
  1045.         (and (pair? curve-list)
  1046.          (if (= (length curve-list) 1)
  1047.              (car curve-list)
  1048.              curve-list))))))
  1049.  
  1050. (define (set-plotter-params plotter . spec-list)
  1051.   (let ((xmin (plotter 'xmin))
  1052.     (xmax (plotter 'xmax))
  1053.     (ymin (plotter 'ymin))
  1054.     (ymax (plotter 'ymax))
  1055.     (axis-x (plotter 'yaxis.xval))
  1056.     (axis-y (plotter 'xaxis.yval))
  1057.     (xticks (plotter 'xticks))
  1058.     (yticks (plotter 'yticks)))
  1059.     (define (process-option name value)
  1060.       (case name
  1061.     ;; global options
  1062.     ((xmin) (set! xmin value))
  1063.     ((xmax) (set! xmax value))
  1064.     ((ymin) (set! ymin value))
  1065.     ((ymax) (set! ymax value))
  1066.     ((axis-x) (set! axis-x value))
  1067.     ((axis-y) (set! axis-y value))
  1068.     ((xticks) (set! xticks value))
  1069.     ((yticks) (set! xticks value))
  1070.     (else (error "Illegal option--SET-PLOTTER-PARAMS" name))))
  1071.     (let process-loop ((options spec-list))
  1072.       (if (not (null? options))
  1073.       (let ((option-name (car options)))
  1074.         (cond ((not (symbol? option-name))
  1075.            (error "Bad option--PLOT" option-name))
  1076.           ((null? (cdr options))
  1077.            (error "SET-PLOTTER-PARAMS: No value specified for option"
  1078.               option-name))
  1079.           (else
  1080.            (let ((option-value (cadr options)))
  1081.              (process-option option-name option-value)
  1082.              (process-loop (cddr options))))))))
  1083.     ((plotter 'set-params) xmin xmax ymin ymax axis-x axis-y xticks yticks)
  1084.     (plotter 'clear)
  1085.     (draw-axes plotter)
  1086.     (plotter 'plot-curves)))
  1087.  
  1088. (define (reset-plotter-params plotter)
  1089.   (apply set-plotter-params
  1090.      (list 'xmin plotter-default-xmin
  1091.            'xmax plotter-default-xmax
  1092.            'ymin plotter-default-ymin
  1093.            'ymax plotter-default-ymax
  1094.            'axis-x plotter-default-axis-x
  1095.            'axis-y plotter-default-axis-y
  1096.            'xticks plotter-default-xticks
  1097.            'yticks plotter-default-yticks)))
  1098.  
  1099.  
  1100. (define (make-vals min max spacing . center?)
  1101.   (let ((min (if center? (* spacing (round (/ min spacing))) min)))
  1102.     (define (tick-maker val)
  1103.       (if (> val max)
  1104.       '()
  1105.       (cons val (tick-maker (+ val spacing)))))
  1106.     (tick-maker min)))
  1107.  
  1108.  
  1109. (define (change-color curve color)
  1110.   ((curve 'change-color) color))
  1111.   
  1112. (define (change-pt-style curve pt-style)
  1113.   ((curve 'change-pt-style) pt-style)
  1114.   (maybe-replot-curve curve))
  1115.  
  1116. (define (change-num-pts curve num-pts)
  1117.   ((curve 'set-num-pts) num-pts)
  1118.   (maybe-replot-curve curve))
  1119.  
  1120. (define (clear-curve curve)
  1121.   (curve 'clear))
  1122.  
  1123. (define (plot-curve curve)
  1124.   (if (curve 'cleared?)
  1125.       (curve 'plot)))
  1126.  
  1127. (define (delete-curve curve)
  1128.   (((curve 'plotter) 'delete-curve) curve))
  1129.  
  1130. (define (add-show-vals curve show-vals)
  1131.   (curve 'clear-vals)
  1132.   ((curve 'set-show-vals)
  1133.    (append (curve 'show-vals) show-vals))
  1134.   (curve 'draw-vals))
  1135.  
  1136. (define (clear-show-vals curve)
  1137.   (curve 'clear-vals))
  1138.  
  1139. (define (draw-show-vals curve)
  1140.   (curve 'draw-vals))
  1141.  
  1142. (define (delete-show-vals curve)
  1143.   (curve 'delete-vals))
  1144.  
  1145.              
  1146. (define (add-xticks plotter xticks)
  1147.   ((plotter 'set-xticks)
  1148.    (append (plotter 'xticks) xticks))
  1149.   (plotter 'clear-axes)
  1150.   (draw-axes plotter))
  1151.  
  1152. (define (add-yticks plotter yticks)
  1153.   ((plotter 'set-yticks)
  1154.    (append (plotter 'xticks) yticks))
  1155.   (plotter 'clear-axes)
  1156.   (draw-axes plotter))
  1157.  
  1158. (define (clear-ticks plotter)
  1159.   (plotter 'clear-ticks))
  1160.  
  1161. (define (draw-ticks plotter)
  1162.   (draw-xticks plotter)
  1163.   (draw-yticks plotter))
  1164.  
  1165. (define (delete-ticks plotter)
  1166.   (plotter 'delete-ticks))
  1167.  
  1168. (define (clear-plotter plotter)
  1169.   (plotter 'clear-curves)
  1170.   (plotter 'clear-ticks))
  1171.  
  1172. (define (replot plotter)
  1173.   (draw-ticks plotter)
  1174.   (for-each plot-curve (plotter 'curve-list))
  1175.   'replotted)
  1176.  
  1177. (define (reset-plotter plotter)
  1178.   (plotter 'delete-curves)
  1179.   (plotter 'delete-ticks)
  1180.   (plotter 'clear)
  1181.   (draw-axes plotter)
  1182.   'reset)
  1183.   
  1184.