home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / gjr / boxes.lha / chipmunk.scm < prev    next >
Encoding:
Text File  |  1991-10-02  |  13.5 KB  |  580 lines
  1. ;;; -*- Scheme -*-
  2.  
  3. #|
  4.  
  5. Copyright (c) 1986-91 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case.
  34.  
  35. |#
  36.  
  37. ;;;; System dependent stuff for box and pointer diagram printer.
  38. ;; Chipmunk (MIT Student Scheme) compatibility file.
  39.  
  40. (define chipmunk-screen
  41.   ;; These are the Chipmunk screen parameters
  42.   (make-rect (make-vect -250 -190)
  43.          (make-vect 500 0)
  44.          (make-vect 0 380)))
  45.  
  46. #|
  47. (define bobcat-screen
  48.   ;; These are the Gator/Bobcat screen parameters
  49.   (make-rect (make-vect -500 -380)
  50.          (make-vect 1000 0)
  51.          (make-vect 0 760)))
  52. |#
  53.  
  54. (define screen chipmunk-screen)
  55.  
  56. (define (drawline start-point end-point)
  57.   (position-pen (xcor start-point)
  58.         (ycor start-point))
  59.   (draw-line-to (xcor end-point)
  60.         (ycor end-point)))
  61.  
  62. ;; clear-graphics is predefined.
  63.  
  64. (define (draw pict)
  65.   (clear-graphics)
  66.   (pict screen))
  67.  
  68. (define draw-permanent draw)
  69.  
  70. ;;; Other dialect dependencies:
  71.  
  72. (define double-quote-string "\"")
  73.  
  74. (define string?
  75.   (access string? '()))
  76.  
  77. (define symbol->string
  78.   (access symbol-print-name '()))
  79.  
  80. (define string-append
  81.   (access string-append '()))
  82.  
  83. (define substring
  84.   (access substring '()))
  85.  
  86. (define number->string
  87.   (let ((prin1-to-string (access write-to-string '())))
  88.     (lambda (x format)
  89.       ;; format is ignored
  90.       (prin1-to-string x))))
  91.  
  92. ;;; text-picture:
  93.  
  94. (define character-width 10)
  95. (define character-height 14)
  96. (define maximum-number-of-characters 8)
  97. (define string-truncation-marker #\#)
  98.  
  99. (define (sign x)
  100.   (if (< x 0) -1 1))
  101.  
  102. ;; All rectangles given to the result of text-picture
  103. ;; are the same size for any given show operation.
  104. ;; Thus, although each invocation recomputes the current
  105. ;; font size, they should all come out the same.
  106.  
  107. (define (text-picture string)
  108.   (lambda (rect)
  109.     (let* ((len (string-length string))
  110.        (rwidth (abs (round (xcor (horiz rect)))))
  111.        (rheight (abs (round (ycor (vert rect))))))
  112.       (define (draw-string charwidth height)
  113.     (let ((nchars (floor (/ rwidth charwidth))))
  114.       (if (or (< rheight height)
  115.           (< nchars 1)
  116.           (and (= nchars 1)
  117.                (not (= len 1))))
  118.           (default-text-picture rect)
  119.           (let ((nstring
  120.              (if (>= nchars len)
  121.              string
  122.              (string-append
  123.               (substring string 0 (- nchars 1))
  124.               (make-string 1
  125.                        string-truncation-marker)))))
  126.         (let ((signx (sign (xcor (horiz rect))))
  127.               (signy (sign (ycor (vert rect))))
  128.               (width (* charwidth (string-length nstring))))
  129.           ((string->picture nstring)
  130.            (make-rect
  131.             (+vect (origin rect)
  132.                (scale .5
  133.                   (make-vect (* signx (- rwidth width))
  134.                          (* signy (- rheight height)))))
  135.             (make-vect (* signx width) 0)
  136.             (make-vect 0 (* signy height)))))))))
  137.       (if (< (floor (/ rwidth character-width)) maximum-number-of-characters)
  138.       (draw-string character-width character-height)
  139.       (let* ((dw (floor (/ rwidth maximum-number-of-characters)))
  140.          (dh (round (/ (* dw character-height) character-width))))
  141.         (if (< dh rheight)
  142.         (draw-string dw dh)
  143.         (draw-string (floor (/ (* rheight character-width)
  144.                        character-width))
  145.                  rheight)))))))
  146.  
  147. ;;;; String->picture
  148.  
  149. (define empty-picture (make-picture '()))
  150.  
  151. (define (string->picture string)
  152.   (let ((n (string-length string)))
  153.     (define (loop m pic)
  154.       (if (= n m)
  155.       pic
  156.       (loop (1+ m)
  157.         (beside pic
  158.             (character-picture (string-ref string m))
  159.             (/ m (1+ m))))))
  160.     (loop 0 empty-picture)))
  161.  
  162. ;;; Character pictures
  163.  
  164. (define character-pictures '())
  165.  
  166. (define (add-character-picture! character picture)
  167.   (let ((place (assq character character-pictures)))
  168.     (sequence
  169.       (if (null? place)
  170.       (set! character-pictures
  171.         (cons (cons character picture)
  172.               character-pictures))
  173.       (set-cdr! place picture))
  174.       'DONE)))
  175.  
  176. (define (character-picture character)
  177.   (let ((place (assq character character-pictures)))
  178.     (if (null? place)
  179.     default-character-picture
  180.     (cdr place))))
  181.  
  182. (define (mpict all)
  183.   (make-picture
  184.    (mapcar (lambda (seg-desc)
  185.          (make-segment (apply make-vect (car seg-desc))
  186.                (apply make-vect (cadr seg-desc))))
  187.        all)))
  188.  
  189. (define (mline all)
  190.   (define (duplicate all)
  191.     (if (null? (cdr all))
  192.     '()
  193.     (cons (list (car all) (cadr all))
  194.           (duplicate (cdr all)))))
  195.   (mpict (duplicate all)))
  196.  
  197. ;;; Computer Terrible Font, by Jinx
  198.  
  199. (define left .15)
  200. (define middle .5)
  201. (define right (- 1 left))
  202. (define bottom .15)
  203. (define top (- 1 bottom))
  204. (define ml .35)
  205. (define mr (- 1 ml))
  206. (define mb .35)
  207. (define mt (- 1 mb))
  208.  
  209. (define default-character-picture    ; A boxed asterisk
  210.   (mpict `(((,left ,bottom) (,right ,top))
  211.        ((,right ,bottom) (,left ,top))
  212.        ((,middle ,bottom) (,middle ,top))
  213.        ((,left ,middle) (,right ,middle))
  214.        ((,left ,top) (,left ,bottom))
  215.        ((,left ,bottom) (,right ,bottom))
  216.        ((,right ,bottom) (,right ,top))
  217.        ((,right ,top) (,left ,top)))))
  218.  
  219. ;;; Punctuation and spacing
  220.  
  221. (add-character-picture!
  222.  #\Space (mpict '()))
  223.  
  224. (add-character-picture!
  225.  #\@
  226.  (mpict `(((,right ,bottom) (,left ,bottom))
  227.       ((,left ,bottom) (,left ,top))
  228.       ((,left ,top) (,right ,top))
  229.       ((,right ,top) (,right ,middle))
  230.       ((,right ,middle) (,middle ,middle))
  231.       ((,middle ,middle) (,middle ,top)))))
  232.  
  233. (add-character-picture!
  234.  #\#
  235.  (mpict `(((,mr ,top) (,mr ,bottom))
  236.       ((,ml ,top) (,ml ,bottom))
  237.       ((,left ,mt) (,right ,mt))
  238.       ((,left ,mb) (,right ,mb)))))
  239.  
  240. (add-character-picture!
  241.  #\"
  242.  (mpict `(((,mr ,top) (,mr ,mt))
  243.       ((,ml ,top) (,ml ,mt)))))
  244.  
  245. (add-character-picture!
  246.  #\.
  247.  (mpict `(((,middle ,middle) (,middle ,middle)))))
  248.  
  249. (add-character-picture!
  250.  #\+
  251.  (mpict `(((,left ,middle) (,right ,middle))
  252.       ((,middle ,top) (,middle ,bottom)))))
  253.  
  254. (add-character-picture!
  255.  #\-
  256.  (mpict `(((,left ,middle) (,right ,middle)))))
  257.  
  258. (add-character-picture!
  259.  #\*
  260.  (mpict `(((,left ,middle) (,right ,middle))
  261.       ((,middle ,top) (,middle ,bottom))
  262.       ((,right ,top) (,left ,bottom))
  263.       ((,left ,top) (,right ,bottom)))))
  264.  
  265. (add-character-picture!
  266.  #\/
  267.  (mpict `(((,left ,bottom) (,right ,top)))))
  268.  
  269. (add-character-picture!
  270.  #\\
  271.  (mpict `(((,right ,bottom) (,left ,top)))))
  272.  
  273. (add-character-picture!
  274.  #\=
  275.  (mpict `(((,left ,middle) (,right ,middle))
  276.       ((,left ,bottom) (,right ,bottom)))))
  277.  
  278. (add-character-picture!
  279.  #\!
  280.  (mpict `(((,middle ,top) (,middle ,middle))
  281.       ((,middle ,bottom) (,middle ,bottom)))))
  282.  
  283. (add-character-picture!
  284.  #\$
  285.  (mpict `(((,left ,bottom) (,right ,bottom))
  286.       ((,right ,bottom) (,right ,middle))
  287.       ((,right ,middle) (,left ,middle))
  288.       ((,left ,middle) (,left ,top))
  289.       ((,left ,top) (,right ,top))
  290.       ((,middle ,top) (,middle ,bottom)))))
  291.  
  292. ;;; Digits
  293.  
  294. (add-character-picture!
  295.  #\0
  296.  (mline `((,mr ,top)
  297.       (,right ,mt)
  298.       (,right ,mb)
  299.       (,mr ,bottom)
  300.       (,ml ,bottom)
  301.       (,left ,mb)
  302.       (,left ,mt)
  303.       (,ml ,top)
  304.       (,mr ,top)
  305.       (,ml ,bottom))))
  306.  
  307. (add-character-picture!
  308.  #\1
  309.  (mpict `(((,ml  ,bottom) (,right ,bottom))
  310.       ((,mr ,bottom) (,mr ,top))
  311.       ((,ml ,mt) (,mr ,top)))))
  312.  
  313. (add-character-picture!
  314.  #\2
  315.  (mline `((,left ,mt)
  316.       (,ml ,top)
  317.       (,mr ,top)
  318.       (,right ,mt)
  319.       (,left ,bottom)
  320.       (,right ,bottom)
  321.       (,right ,mb))))
  322.  
  323. (add-character-picture!
  324.  #\3
  325.  (mline `((,left ,top)
  326.       (,right ,top)
  327.       (,middle ,middle)
  328.       (,mr ,middle)
  329.       (,right ,mb)
  330.       (,mr ,bottom)
  331.       (,ml ,bottom)
  332.       (,left ,mb))))
  333.  
  334. (add-character-picture!
  335.  #\4
  336.  (mline `((,mr ,bottom)
  337.       (,mr ,top)
  338.       (,left ,middle)
  339.       (,right ,middle))))
  340.  
  341. (add-character-picture!
  342.  #\5
  343.  (mline `((,right ,top)
  344.       (,left ,top)
  345.       (,left ,middle)
  346.       (,middle ,mt)
  347.       (,right ,middle)
  348.       (,right ,mb)
  349.       (,middle ,bottom)
  350.       (,left ,mb))))
  351.  
  352. (add-character-picture!
  353.  #\6
  354.  (mpict `(((,right ,top) (,left ,top))
  355.       ((,left ,top) (,left ,bottom))
  356.       ((,left ,bottom) (,right ,bottom))
  357.       ((,right ,bottom) (,right ,middle))
  358.       ((,right ,middle) (,left ,middle)))))
  359.  
  360. (add-character-picture!
  361.  #\7
  362.  (mpict `(((,left ,top) (,right ,top))
  363.       ((,right ,top) (,ml ,bottom))
  364.       ((,ml ,middle) (,mr ,middle)))))
  365.  
  366. (add-character-picture!
  367.  #\8
  368.  (mpict `(((,left ,top) (,right ,top))
  369.       ((,right ,top) (,right ,bottom))
  370.       ((,right ,bottom) (,left ,bottom))
  371.       ((,left ,bottom) (,left ,top))
  372.       ((,left ,middle) (,right ,middle)))))
  373.  
  374. (add-character-picture!
  375.  #\9
  376.  (mpict `(((,right ,bottom) (,right ,top))
  377.       ((,right ,top) (,left ,top))
  378.       ((,left ,top) (,left ,middle))
  379.       ((,left ,middle) (,right ,middle)))))
  380.  
  381. ;;; Upper case alphabetic characters
  382.  
  383. (add-character-picture!
  384.  #\A
  385.  (mpict `(((,left ,bottom) (,right ,top))
  386.       ((,right ,top) (,right ,bottom))
  387.       ((,middle ,middle) (,right ,middle)))))
  388.  
  389. (add-character-picture!
  390.  #\B
  391.  (mline `((,mr ,middle)
  392.       (,right ,mt)
  393.       (,mr ,top)
  394.       (,left ,top)
  395.       (,left ,bottom)
  396.       (,mr ,bottom)
  397.       (,right ,mb)
  398.       (,mr ,middle)
  399.       (,left ,middle))))
  400.  
  401. (add-character-picture!
  402.  #\C
  403.  (mline `((,right ,mb)
  404.       (,mr ,bottom)
  405.       (,ml ,bottom)
  406.       (,left ,mb)
  407.       (,left ,mt)
  408.       (,ml ,top)
  409.       (,mr ,top)
  410.       (,right ,mt))))
  411.  
  412. (add-character-picture!
  413.  #\D
  414.  (mline `((,right ,mt)
  415.       (,middle ,top)
  416.       (,left ,top)
  417.       (,left ,bottom)
  418.       (,middle ,bottom)
  419.       (,right ,mb)
  420.       (,right ,mt))))
  421.  
  422. (add-character-picture!
  423.  #\E
  424.  (mpict `(((,right ,top) (,left ,top))
  425.       ((,left ,top) (,left ,bottom))
  426.       ((,left ,bottom) (,right ,bottom))
  427.       ((,left ,middle) (,right ,middle)))))
  428.  
  429. (add-character-picture!
  430.  #\F
  431.  (mpict `(((,right ,top) (,left ,top))
  432.       ((,left ,top) (,left ,bottom))
  433.       ((,left ,middle) (,right ,middle)))))
  434.  
  435. (add-character-picture!
  436.  #\G
  437.  (mpict `(((,right ,top) (,left ,top))
  438.       ((,left ,top) (,left ,bottom))
  439.       ((,left ,bottom) (,right ,bottom))
  440.       ((,right ,bottom) (,right ,middle))
  441.       ((,right ,middle) (,middle ,middle)))))
  442.  
  443. (add-character-picture!
  444.  #\H
  445.  (mpict `(((,left ,top) (,left ,bottom))
  446.       ((,right ,top) (,right ,bottom))
  447.       ((,left ,middle) (,right ,middle)))))
  448.  
  449. (add-character-picture!
  450.  #\I
  451.  (mpict `(((,left ,top) (,right ,top))
  452.       ((,middle ,top) (,middle ,bottom))
  453.       ((,left ,bottom) (,right ,bottom)))))
  454.  
  455. (add-character-picture!
  456.  #\J
  457.  (mline `((,ml ,mt)
  458.       (,ml ,top)
  459.       (,right ,top)
  460.       (,right ,mb)
  461.       (,mr ,bottom)
  462.       (,ml ,bottom)
  463.       (,left ,mb))))
  464.  
  465. (add-character-picture!
  466.  #\K
  467.  (mpict `(((,left ,top) (,left ,bottom))
  468.       ((,left ,middle) (,right ,top))
  469.       ((,left ,middle) (,right ,bottom)))))
  470.  
  471. (add-character-picture!
  472.  #\L
  473.  (mpict `(((,left ,top) (,left ,bottom))
  474.       ((,left ,bottom) (,right ,bottom)))))
  475.  
  476. (add-character-picture!
  477.  #\M
  478.  (mpict `(((,left ,bottom) (,left ,top))
  479.       ((,left ,top) (,middle ,middle))
  480.       ((,middle ,middle) (,right ,top))
  481.       ((,right ,top) (,right ,bottom)))))
  482.  
  483. (add-character-picture!
  484.  #\N
  485.  (mpict `(((,left ,bottom) (,left ,top))
  486.       ((,left ,top) (,right ,bottom))
  487.       ((,right ,bottom) (,right ,top)))))
  488.  
  489. (add-character-picture!
  490.  #\O
  491.  (mline `((,mr ,top)
  492.       (,right ,mt)
  493.       (,right ,mb)
  494.       (,mr ,bottom)
  495.       (,ml ,bottom)
  496.       (,left ,mb)
  497.       (,left ,mt)
  498.       (,ml ,top)
  499.       (,mr ,top))))
  500.  
  501. (add-character-picture!
  502.  #\P
  503.  (mpict `(((,left ,bottom) (,left ,top))
  504.       ((,left ,top) (,right ,top))
  505.       ((,right ,top) (,right ,middle))
  506.       ((,right ,middle) (,left ,middle)))))
  507.  
  508. (add-character-picture!
  509.  #\Q
  510.  (mpict `(((,mr ,top) (,right ,mt))
  511.       ((,right ,mt) (,right ,mb))
  512.       ((,right ,mb) (,mr ,bottom))
  513.       ((,mr ,bottom) (,ml ,bottom))
  514.       ((,ml ,bottom) (,left ,mb))
  515.       ((,left ,mb) (,left ,mt))
  516.       ((,left ,mt) (,ml ,top))
  517.       ((,ml ,top) (,mr ,top))
  518.       ((,middle ,middle) (,right ,bottom)))))
  519.  
  520. (add-character-picture!
  521.  #\R
  522.  (mpict `(((,left ,bottom) (,left ,top))
  523.       ((,left ,top) (,right ,top))
  524.       ((,right ,top) (,right ,middle))
  525.       ((,right ,middle) (,left ,middle))
  526.       ((,middle ,middle) (,right ,bottom)))))
  527.       
  528. (add-character-picture!
  529.  #\S
  530.  (mline `((,right ,mt)
  531.       (,mr ,top)
  532.       (,ml ,top)
  533.       (,left ,mt)
  534.       (,right ,mb)
  535.       (,mr ,bottom)
  536.       (,ml ,bottom)
  537.       (,left ,mb))))
  538.  
  539. (add-character-picture!
  540.  #\T
  541.  (mpict `(((,left ,top) (,right ,top))
  542.       ((,middle ,top) (,middle ,bottom)))))
  543.  
  544. (add-character-picture!
  545.  #\U
  546.  (mline `((,left ,top)
  547.       (,left ,mb)
  548.       (,ml ,bottom)
  549.       (,mr ,bottom)
  550.       (,right ,mb)
  551.       (,right ,top))))
  552.  
  553. (add-character-picture!
  554.  #\V
  555.  (mpict `(((,left ,top) (,middle ,bottom))
  556.       ((,middle ,bottom) (,right ,top)))))
  557.  
  558. (add-character-picture!
  559.  #\W
  560.  (mpict `(((,left ,top) (,left ,bottom))
  561.       ((,left ,bottom) (,middle ,middle))
  562.       ((,middle ,middle) (,right ,bottom))
  563.       ((,right ,bottom) (,right ,top)))))
  564.  
  565. (add-character-picture!
  566.  #\X
  567.  (mpict `(((,left ,top) (,right ,bottom))
  568.       ((,right ,top) (,left ,bottom)))))
  569.  
  570. (add-character-picture!
  571.  #\Y
  572.  (mpict `(((,left ,top) (,middle ,middle))
  573.       ((,right ,top) (,middle ,middle))
  574.       ((,middle ,middle) (,middle ,bottom)))))
  575.  
  576. (add-character-picture!
  577.  #\Z
  578.  (mpict `(((,left ,top) (,right ,top))
  579.       ((,right ,top) (,left ,bottom))
  580.       ((,left ,bottom) (,right ,bottom)))))