home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lisp / interpre / xlispplu / lsp / turtle.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-01-14  |  3.8 KB  |  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. (if (fboundp 'get-internal-run-time)
  33.     (defun pause (time) 
  34.        (let ((fintime (+ (* time internal-time-units-per-second)
  35.                  (get-internal-run-time))))
  36.         (loop (when (> (get-internal-run-time) fintime)
  37.                 (return-from pause)))))
  38.     (defun pause () (dotimes (x (* time 1000)))))
  39.  
  40.  
  41. (defun TurtleGraphicsUp()           
  42.        (case *GMODE*
  43.          (6                ; 640x200 B&W mode
  44.           (mode 6)
  45.           (setq CenterX 100 CenterY 100 Scale 3.2 Lfactor 1) 
  46.           (TurtleCenter))  
  47.          (16            ; 640x350 Graphics
  48.           (mode 16)
  49.           (setq CenterX 175 CenterY 175 Scale 1.83 Lfactor 1.75) 
  50.           (TurtleCenter))  
  51.          (18            ; 640x480 VGA Graphics
  52.           (mode 18)
  53.           (setq CenterX 240 CenterY 240 Scale 1.33 Lfactor 2.4) 
  54.           (TurtleCenter))  
  55.          (t (error "unsupported *GMODE*" *GMODE*))
  56.        )
  57.        (color 15)
  58. )   
  59.  
  60. (defun TurtleGraphicsDown() 
  61.     (mode 3))
  62. (defun TurtleCenter()       
  63.     (setq Lastx CenterX Lasty CenterY Heading 1.570796372))
  64. (defun TurtleRight(n)       (setq Heading (- Heading (* n 0.01745329))))
  65. (defun TurtleLeft(n)        (setq Heading (+ Heading (* n 0.01745329))))
  66. (defun TurtleGoto(x y)      (setq Lastx (* x Lfactor) Lasty (* y Lfactor) )) 
  67.  
  68. (defun TurtleForward(n) 
  69.       (setq n (* n Lfactor) 
  70.               Newx (+ Lastx (* (cos Heading) n))
  71.         Newy (+ Lasty (* (sin Heading) n)))
  72.       (move (truncate (* Lastx Scale))
  73.             (truncate Lasty)
  74.         (truncate (* Newx Scale))
  75.         (truncate Newy))
  76.       (setq Lastx Newx Lasty Newy)
  77. )
  78.  
  79. ;
  80. ; end of Turtle Graphics primitives, start of Graphics demonstration code
  81. ; you can cut this out if you like and leave the Turtle primitives intact.
  82. ;
  83.  
  84. (defun Line_T(n)        
  85.     (TurtleForward n) (TurtleRight 180)
  86.     (TurtleForward (/ n 4)) 
  87. )
  88.     
  89. (defun Square(n)
  90.     (TurtleForward n)  (TurtleRight 90)     
  91.     (TurtleForward n)  (TurtleRight 90)     
  92.     (TurtleForward n)  (TurtleRight 90)     
  93.     (TurtleForward n)                       
  94. )
  95.  
  96. (defun Triangle(n)
  97.     (TurtleForward n)  (TurtleRight 120)
  98.     (TurtleForward n)  (TurtleRight 120)
  99.     (TurtleForward n)
  100. )
  101.  
  102. (defun Make(ObjectFunc Size star skew) 
  103.       (dotimes (dummy star)
  104.        (apply ObjectFunc (list Size)) 
  105.        (TurtleRight skew)
  106.        )
  107. )
  108.  
  109. (defun GraphicsDemo()
  110.        (TurtleGraphicsUp) 
  111.        (Make #'Square 40 18 5) (Make #'Square 60 18 5)
  112.        (pause 1.0)
  113.        (TurtleGraphicsUp) 
  114.        (Make #'Triangle 40 18 5) (Make #'Triangle 60 18 5)
  115.        (pause 1.0)
  116.        (TurtleGraphicsUp) 
  117.        (Make #'Line_T 80 50 10)
  118.        (pause 1.0)
  119.        (TurtleGraphicsDown)
  120. )
  121.  
  122. (print "Try (GraphicsDemo)")
  123.  
  124.