home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / magazine / aijournl / 1986_09 / cli.sai < prev    next >
Text File  |  1986-06-07  |  2KB  |  71 lines
  1.  
  2.  
  3. CLI LISP Drunken Sailor Problem
  4.  
  5.  
  6. ;
  7. ;; The Drunken Sailor Problem
  8. ;
  9. (defun drunken ()
  10.   (lo-res)
  11.   (set-pallette 1)
  12.   (setf x 160
  13.     y 100
  14.         *step* 5
  15.         *-step* (- *step*)
  16.         side 70
  17.         xbot (- x side)
  18.         xtop (+ x side)
  19.         ybot (- y side)
  20.         ytop (+ y side))
  21.   ; draw the starting location
  22.   (draw-box x y *step* *-step*)
  23.   ; draw the finish line
  24.   (draw-box x y side (- side))
  25.   ; set a large time slice because there will be alot of switching
  26.   (setf *time-slice* 300)
  27.   ; initiate concurrent execution
  28.   (cobegin '(walk x y 1) '(walk x y 2) '(walk x y 3))
  29.   (alpha)
  30. )
  31. (defun draw-box (x y d+ d-)
  32.   (%draw-line (+ x d-) (+ y d-) (+ x d+) (+ y d-) 1 0)
  33.   (%draw-line (+ x d+) (+ y d-) (+ x d+) (+ y d+) 1 0)
  34.   (%draw-line (+ x d+) (+ y d+) (+ x d-) (+ y d+) 1 0)
  35.   (%draw-line (+ x d-) (+ y d+) (+ x d-) (+ y d-) 1 0)è)
  36. (defun walk (x y color)
  37.   (let ((x-old x)
  38.         (y-old y))
  39.   (do ((x-new (step x-old)
  40.               (step x-old))
  41.        (y-new (step y-old)
  42.               (step y-old)))
  43.       ((done-p x-old y-old))
  44.     ; use the gclisp drawing primitive
  45.     (%draw-line x-old y-old x-new y-new color 0)
  46.     (setf x-old x-new)
  47.     (setf y-old y-new)))
  48. )
  49. (defun step (old)
  50.   ; take random steps
  51.   (+ old (rand *-step* *step*))
  52. )
  53. (defun done-p (x y)
  54.   (or (< x xbot) (> x xtop)
  55.       (< y ybot) (> y ytop))
  56. )
  57. ; taken from the gclisp examples
  58. ; load the line drawing primitive
  59. (UNLESS (FBOUNDP '%DRAW-LINE)
  60.   (WITH-DISKETTE *EXAMPLE-DISKETTE* #'FASLOAD
  61.      (MERGE-PATHNAMES "DLINE.FAS" *EXAMPLE-PATHNAME*)))
  62. ; switch to lo-resolution graphics
  63. (DEFUN LO-RES () (%sysint #X10 4 0 0 0) t)
  64. ; return to alphanumeric
  65. (DEFUN ALPHA () (%sysint #X10 3 0 0 0) t)
  66. ; set the colors (1 or 2)
  67. (defun set-pallette (x)
  68.   (%sysint #x10 #x0b00 (logior #x100 (logand x 1)) 0 0)
  69. )
  70.  
  71.