220 lines
5.4 KiB
Common Lisp
220 lines
5.4 KiB
Common Lisp
;File: GRAPHICS.LSP (c) 12/27/85 Soft Warehouse, Inc.
|
||
|
||
|
||
; This file contains the graphics functions defined in muLISP Lesson #6.
|
||
|
||
(SETQ COLUMNS 80) ; Number of columns on your screen.
|
||
|
||
(SETQ ROWS 24) ; Number of rows on your screen.
|
||
|
||
; DOT is the character graphics primitive function. It requires that
|
||
; (SET-CURSOR row column) be properly defined for your computer and terminal.
|
||
|
||
(DEFUN DOT (X-COORD Y-COORD
|
||
LINELENGTH )
|
||
((AND (< (- X-MAX) X-COORD X-MAX)
|
||
(< (- Y-MAX) Y-COORD Y-MAX) )
|
||
(SET-CURSOR (- Y-MAX Y-COORD) (+ X-MAX X-COORD))
|
||
(PRIN1 DOT) ) )
|
||
|
||
(SETQ X-MAX (TRUNCATE (ADD1 COLUMNS) 2))
|
||
|
||
(SETQ Y-MAX (TRUNCATE (ADD1 ROWS) 2))
|
||
|
||
(SETQ DOT '*)
|
||
|
||
(DEFUN DRAW (NLAMBDA COMMANDS
|
||
(CLEAR-SCREEN)
|
||
(MAPC 'EVAL COMMANDS)
|
||
(SET-CURSOR 0 0) ))
|
||
|
||
(DEFUN LINE (X1 Y1 X2 Y2
|
||
DELTA-X DELTA-Y SIGN-DELTA-X SIGN-DELTA-Y)
|
||
(SETQ DELTA-X (- X2 X1)
|
||
DELTA-Y (- Y2 Y1)
|
||
SIGN-DELTA-X (SIGNUM DELTA-X)
|
||
SIGN-DELTA-Y (SIGNUM DELTA-Y)
|
||
DELTA-X (ABS DELTA-X)
|
||
DELTA-Y (ABS DELTA-Y))
|
||
((< DELTA-Y DELTA-X)
|
||
(SETQ DELTA-Y (+ DELTA-Y DELTA-Y) ;Gentle slope
|
||
Y2 (- DELTA-Y DELTA-X)
|
||
DELTA-X (- DELTA-X Y2))
|
||
(LOOP
|
||
(DOT X1 Y1)
|
||
((EQ X1 X2))
|
||
( ((PLUSP Y2)
|
||
(INCQ Y1 SIGN-DELTA-Y)
|
||
(DECQ Y2 DELTA-X) )
|
||
(INCQ Y2 DELTA-Y) )
|
||
(INCQ X1 SIGN-DELTA-X) ) )
|
||
(SETQ DELTA-X (+ DELTA-X DELTA-X) ;Steep slope
|
||
X2 (- DELTA-X DELTA-Y)
|
||
DELTA-Y (- DELTA-Y X2))
|
||
(LOOP
|
||
(DOT X1 Y1)
|
||
((EQ Y1 Y2))
|
||
( ((PLUSP X2)
|
||
(INCQ X1 SIGN-DELTA-X)
|
||
(DECQ X2 DELTA-Y) )
|
||
(INCQ X2 DELTA-X) )
|
||
(INCQ Y1 SIGN-DELTA-Y) ) )
|
||
|
||
|
||
(DEFUN REDUCED-SIN (DEG)
|
||
(/ (* DEG (+ 1324959969 (* (SETQ DEG (* DEG DEG)) (+ -67245 DEG))))
|
||
75914915920) )
|
||
|
||
(DEFUN REDUCED-COS (DEG)
|
||
(SETQ DEG (* DEG DEG))
|
||
(/ (+ 266153374 (* DEG (+ -40518 DEG)))
|
||
266153374) )
|
||
|
||
(DEFUN SIN-DEG (ANGLE)
|
||
((MINUSP ANGLE)
|
||
(SETQ ANGLE (DIVIDE (REM (- ANGLE) 360) 45))
|
||
(- (SIN-COS-DEG (CAR ANGLE) (CDR ANGLE))) )
|
||
(SETQ ANGLE (DIVIDE (REM ANGLE 360) 45))
|
||
(SIN-COS-DEG (CAR ANGLE) (CDR ANGLE)) )
|
||
|
||
(DEFUN COS-DEG (ANGLE)
|
||
(SETQ ANGLE (DIVIDE (REM (ABS ANGLE) 360) 45))
|
||
(SIN-COS-DEG (+ 2 (CAR ANGLE)) (CDR ANGLE)) )
|
||
|
||
(DEFUN SIN-COS-DEG (N45DEG RESID)
|
||
((> N45DEG 3)
|
||
(- (SIN-COS-DEG (- N45DEG 4) RESID)) )
|
||
((ZEROP N45DEG) (REDUCED-SIN RESID))
|
||
((EQL N45DEG 1) (REDUCED-COS (- 45 RESID)))
|
||
((EQL N45DEG 2) (REDUCED-COS RESID))
|
||
(REDUCED-SIN (- 45 RESID)) )
|
||
|
||
|
||
(DEFUN SETPOS (X Y)
|
||
(SETQ X-POS X Y-POS Y) )
|
||
|
||
(DEFUN TURN (ANGLE)
|
||
(SETQ HEADING (REM (+ HEADING ANGLE) 360)) )
|
||
|
||
(DEFUN SETHEADING (ANGLE)
|
||
(SETQ HEADING (REM ANGLE 360)) )
|
||
|
||
(DEFUN PENDOWN ()
|
||
(SETQ PENDOWN T) )
|
||
|
||
(DEFUN PENUP ()
|
||
(SETQ PENDOWN NIL) )
|
||
|
||
|
||
(DEFUN TURTLE (NLAMBDA COMMANDS
|
||
(SETPOS 0 0)
|
||
(SETHEADING 0)
|
||
(PENDOWN)
|
||
(APPLY 'DRAW COMMANDS) ))
|
||
|
||
(DEFUN FORWARD (DISTANCE
|
||
X-OLD Y-OLD )
|
||
(SETQ X-OLD X-POS)
|
||
(SETQ Y-OLD Y-POS)
|
||
(INCQ X-POS (ROUND (* DISTANCE (SIN-DEG HEADING))))
|
||
(INCQ Y-POS (ROUND (* DISTANCE (COS-DEG HEADING))))
|
||
((NOT PENDOWN))
|
||
(LINE X-OLD Y-OLD X-POS Y-POS) )
|
||
|
||
(DEFUN FORWARD-THEN-TURN (DISTANCE ANGLE)
|
||
(FORWARD DISTANCE)
|
||
(TURN ANGLE) )
|
||
|
||
|
||
(DEFUN POLY (SIDE ANGLE
|
||
TOT-TURN)
|
||
(SETQ TOT-TURN 0)
|
||
(LOOP
|
||
(FORWARD-THEN-TURN SIDE ANGLE)
|
||
(SETQ TOT-TURN (REM (+ TOT-TURN ANGLE) 360))
|
||
((ZEROP TOT-TURN)) ) )
|
||
|
||
(DEFUN CORN-POL (SIDE ANGLE
|
||
TOT-TURN)
|
||
((> SIDE 1)
|
||
(SETQ TOT-TURN 0)
|
||
(LOOP
|
||
(FORWARD SIDE)
|
||
(CORN-POL (SHIFT SIDE -2) (- ANGLE))
|
||
(TURN ANGLE)
|
||
(SETQ TOT-TURN (REM (+ TOT-TURN ANGLE) 360))
|
||
((ZEROP TOT-TURN)) ) ) )
|
||
|
||
(DEFUN SPIRAL (SIDE ANGLE INCR)
|
||
(LOOP
|
||
((< SIDE INCR))
|
||
(FORWARD-THEN-TURN SIDE ANGLE)
|
||
(DECQ SIDE INCR) ) )
|
||
|
||
(DEFUN SPIROLAT (SIDE ANGLE INCR
|
||
TOT-TURN)
|
||
(SETQ TOT-TURN 0)
|
||
(LOOP
|
||
(SPIRAL SIDE ANGLE INCR)
|
||
(SETQ TOT-TURN (REM (+ TOT-TURN (* ANGLE (TRUNCATE SIDE INCR))) 360))
|
||
((ZEROP TOT-TURN)) ) )
|
||
|
||
(DEFUN IBM-DOT (X-COORD Y-COORD)
|
||
((AND (< -161 X-COORD 160)
|
||
(< -101 Y-COORD 100) )
|
||
(REGISTER 2 (+ 160 X-COORD))
|
||
(REGISTER 3 (- 100 Y-COORD))
|
||
(REGISTER 0 *COLOR*)
|
||
(INTERRUPT 16) ) )
|
||
|
||
(MOVD 'IBM-DOT 'DOT) ;Use IBM plot dot routine
|
||
|
||
(DEFUN SETCOLOR (COLOR)
|
||
(SETQ *COLOR* (+ 3071 (LENGTH (MEMBER COLOR
|
||
'(WHITE RED GREEN BLACK))))) )
|
||
|
||
(SETCOLOR WHITE)
|
||
|
||
(DEFUN GRAPHICS-MODE () ;Sets up 320 x 200 color graphics mode
|
||
(REGISTER 0 4)
|
||
(INTERRUPT 16)
|
||
(MAKE-WINDOW 0 0 25 40) )
|
||
|
||
(DEFUN ALPHA-MODE () ;Sets up 25 x 80 color alpha mode
|
||
(REGISTER 0 3)
|
||
(INTERRUPT 16)
|
||
(CURSOR-LINES NIL)
|
||
(MAKE-WINDOW 0 0 25 80) )
|
||
|
||
(DEFUN TURTLE (NLAMBDA COMMANDS
|
||
(IF (NEQ (CADDDR (MAKE-WINDOW)) 40) (GRAPHICS-MODE) )
|
||
(MAKE-WINDOW 0 0 21 40)
|
||
(SETPOS 0 0)
|
||
(SETHEADING 0)
|
||
(PENDOWN)
|
||
(CATCH 'DRIVER (APPLY 'DRAW COMMANDS))
|
||
(MAKE-WINDOW 21 0 4 40)
|
||
(SET-CURSOR 3 0) ))
|
||
|
||
(DEFUN C-CURVE (DEPTH) ;"C" curve function
|
||
((ZEROP DEPTH)
|
||
(FORWARD *LENGTH*) )
|
||
(TURN 45)
|
||
(C-CURVE (SUB1 DEPTH))
|
||
(TURN -90)
|
||
(C-CURVE (SUB1 DEPTH))
|
||
(TURN 45) )
|
||
|
||
(SETQ *LENGTH* 3)
|
||
|
||
(DEFUN D-CURVE (DEPTH FLAG) ;"Dragon" curve function
|
||
((ZEROP DEPTH)
|
||
(FORWARD *LENGTH*) )
|
||
(IF FLAG (TURN 45) (TURN -45))
|
||
(D-CURVE (SUB1 DEPTH) T)
|
||
(IF FLAG (TURN -90) (TURN 90))
|
||
(D-CURVE (SUB1 DEPTH) NIL)
|
||
(IF FLAG (TURN 45) (TURN -45)) )
|
||
|
||
(RDS)
|
||
|