home *** CD-ROM | disk | FTP | other *** search
/ Dream 52 / Amiga_Dream_52.iso / RiscOS / APP / DEVS / LISP / CLISP.ZIP / CLisp / lsp / turtle < prev    next >
Lisp/Scheme  |  1992-10-02  |  4KB  |  124 lines
  1. ;; TURTLE.L for PC-LISP.EXE V2.10
  2. ;; Modified for XLISP 2.1d by Tom Almy
  3. ;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  4. ;;      A set of turtle graphics primitives to demonstrate PC-LISP's BIOS 
  5. ;; graphics routines. These routines are pretty self explanitory. The first
  6. ;; 5 defun's define the primitives, next are a set of routines to draw things
  7. ;; like squares, triangles etc. Try the function (GraphicsDemo). It will
  8. ;; draw Squirals, Trianglerals, etc. Note that the BIOS line drawing is really
  9. ;; slow. This is because the BIOS 'set dot/pixel' routine is used for every
  10. ;; point in a line. Using the BIOS has the advantage however of portability,
  11. ;; these routines work on virtually every MS-DOS machine. The global variable
  12. ;; *GMODE* controls the graphics resolution that will be used. It is set by 
  13. ;; default to 6 I set it to 8 or 9 for my 2000 but these routines will not
  14. ;; support the lower resolution modes. 
  15. ;;
  16. ;;                      Peter Ashwood-Smith
  17. ;;                      April 2nd, 1986 
  18. ;;
  19.  
  20.  
  21. ;; Several bugs  fixed by Tom Almy
  22. ;; The playing field is 200x200, after scaling.
  23. ;; Lfactor = ypixels/200
  24. ;; Scale = xpixels/ypixels
  25. ;; CenterX=CenterY= ypixels/2
  26.  
  27.  
  28.  
  29. (defvar *GMODE* 18)                                     ; default setting
  30.  
  31.  
  32. #+:times (defun pause (time) 
  33.        (let ((fintime (+ (* time internal-time-units-per-second)
  34.                  (get-internal-run-time))))
  35.         (loop (when (> (get-internal-run-time) fintime)
  36.                 (return-from pause)))))
  37. #-:times (defun pause () (dotimes (x (* time 1000))))
  38.  
  39.  
  40. (defun TurtleGraphicsUp()           
  41.        (case *GMODE*
  42.          (6                ; 640x200 B&W mode
  43.           (mode 6)
  44.           (setq CenterX 100 CenterY 100 Scale 3.2 Lfactor 1) 
  45.           (TurtleCenter))  
  46.          (16            ; 640x350 Graphics
  47.           (mode 16)
  48.           (setq CenterX 175 CenterY 175 Scale 1.83 Lfactor 1.75) 
  49.           (TurtleCenter))  
  50.          (18            ; 640x480 VGA Graphics
  51.           (mode 18)
  52.           (setq CenterX 240 CenterY 240 Scale 1.33 Lfactor 2.4) 
  53.           (TurtleCenter))  
  54.          (t (error "unsupported *GMODE*" *GMODE*))
  55.        )
  56.        (color 15)
  57. )   
  58.  
  59. (defun TurtleGraphicsDown() 
  60.     (mode 3))
  61. (defun TurtleCenter()       
  62.     (setq Lastx CenterX Lasty CenterY Heading 1.570796372))
  63. (defun TurtleRight(n)       (setq Heading (- Heading (* n 0.01745329))))
  64. (defun TurtleLeft(n)        (setq Heading (+ Heading (* n 0.01745329))))
  65. (defun TurtleGoto(x y)      (setq Lastx (* x Lfactor) Lasty (* y Lfactor) )) 
  66.  
  67. (defun TurtleForward(n) 
  68.       (setq n (* n Lfactor) 
  69.               Newx (+ Lastx (* (cos Heading) n))
  70.         Newy (+ Lasty (* (sin Heading) n)))
  71.       (move (truncate (* Lastx Scale))
  72.             (truncate Lasty)
  73.         (truncate (* Newx Scale))
  74.         (truncate Newy))
  75.       (setq Lastx Newx Lasty Newy)
  76. )
  77.  
  78. ;
  79. ; end of Turtle Graphics primitives, start of Graphics demonstration code
  80. ; you can cut this out if you like and leave the Turtle primitives intact.
  81. ;
  82.  
  83. (defun Line_T(n)        
  84.     (TurtleForward n) (TurtleRight 180)
  85.     (TurtleForward (/ n 4)) 
  86. )
  87.     
  88. (defun Square(n)
  89.     (TurtleForward n)  (TurtleRight 90)     
  90.     (TurtleForward n)  (TurtleRight 90)     
  91.     (TurtleForward n)  (TurtleRight 90)     
  92.     (TurtleForward n)                       
  93. )
  94.  
  95. (defun Triangle(n)
  96.     (TurtleForward n)  (TurtleRight 120)
  97.     (TurtleForward n)  (TurtleRight 120)
  98.     (TurtleForward n)
  99. )
  100.  
  101. (defun Make(ObjectFunc Size star skew) 
  102.       (dotimes (dummy star)
  103.        (apply ObjectFunc (list Size)) 
  104.        (TurtleRight skew)
  105.        )
  106. )
  107.  
  108. (defun GraphicsDemo()
  109.        (TurtleGraphicsUp) 
  110.        (Make #'Square 40 18 5) (Make #'Square 60 18 5)
  111.        (pause 1.0)
  112.        (TurtleGraphicsUp) 
  113.        (Make #'Triangle 40 18 5) (Make #'Triangle 60 18 5)
  114.        (pause 1.0)
  115.        (TurtleGraphicsUp) 
  116.        (Make #'Line_T 80 50 10)
  117.        (pause 1.0)
  118.        (TurtleGraphicsDown)
  119. )
  120.  
  121. (print "Try (GraphicsDemo)")
  122.  
  123. (setq *features* (cons :turtle *features*))
  124.