dos_compilers/Microsoft muLISP-86 v51/GRAPHICS.LSP

;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)