;;; -*- Mode:LISP; Package:GREY; Base:8; Readtable:ZL -*-

;; Copyright LISP Machine, Inc. 1984, 1985, 1986
;;    See filename "Copyright.Text" for
;; licensing and release information.

(DEFUN HELP ()
  (FORMAT T
	  "~%The video memory has been set up as an art-8b with name
GREY-SCREEN-ARRAY.  Its dimensions are (576. 454.) and it can be accessed via standard LISP array
functions, or functions like.  There are 256. colors in this display.
These are initialized for grey-levels but can be altered for color.  The video memory is also
set up as eight art-1b arrays with names GREY-SCREEN-PLANE-ARRAY0,...,GREY-SCREEN-PLANE-ARRAY7.  
These correspond to the eight bit planes and can also be accessed via standard array functions.
				
Some useful functions in this package:
	SCALE		 -	Writes out a grey scale
	STRAIGHT-MAP	 -	Reloads the map for grey levels.
	WRITE-COLOR-MAP  -	Takes arguments:  COLOR R G B
				Defines a specific color as a mix of R, G, & B.
	READ-COLOR-MAP	 -	Takes argument:  COLOR
				Returns list:  (R G B)
	PALETTE		 -	Shows you all colors.
	SPECTRUM	 -	Attempts to display a spectrum.
	GRAB-FRAMES	 -	Turns on frame-grabbing. The space bar toggles between
					grabbing and freezing.  Carriage return exits.
	BLT		 -	Takes arguments: FROM-ARRAY TO-ARRAY(both 576. x 454.)
					BITBLT's between them.
	SAVE-IMAGE	 -	Takes arguments ARRAY FILENAME
				Saves ARRAY in specified file.
				Use LOAD or FASLOAD to load image.
	WAIT-FOR-VSYNC	 -	Waits for vertical sync.
	SELECT-PLANE	 -	Takes argument:  PLANE-NUMBER
				Sets up color map to select that plane on display.
	RAM-TEST	 -	Runs address and data tests on video memory.
	DOWN-LOAD	 -	Resets and downloads color board.
	REINITIALIZE-SCREEN -	Resets GREY-ARRAY. Not normally recommended.~%"
	  ))

;;;; INITIALIZATION AND CONTROL FUNCTIONS




;In direct mode, the IO address are set up relative to IO space, so as to win
;with %XBUS-WRITE.  The video buffer is referenced as a direct-mapped physical
;address.  It can also be referenced by giving a negative argument to
;%XBUS-WRITE, etc.
;Note: you had really better call this function instead of depending on things to be
;setup directly from readin, since it does a WRITE-METER which moves down the
;boundary between IO space and Swapped virtual memory to include the video buffer
;addresses.
(comment   ;this is the way it was on the CADR.
(DEFUN USE-DIRECT NIL
  (SETQ DIRECT-MODE T
	WRITE-FUNCTION '%XBUS-WRITE
	READ-FUNCTION '%XBUS-READ
	UNIBUS-WRITE-FUNCTION '%UNIBUS-WRITE
	UNIBUS-READ-FUNCTION '%UNIBUS-READ)
  (SET-BASE 377530)
  (SETQ VIDEO-BUFFER-BASE-ADDRESS -1400000)		;pixel orig, tv 3.
  (LET ((VORG (+ 77000000 VIDEO-BUFFER-BASE-ADDRESS)))  ;Note adding minus number.
    (SETQ VIDEO-BUFFER-BASE-VIRTUAL-ADDRESS VORG)
    (SETQ VIDEO-BUFFER-BASE-VIRTUAL-ADDRESS-AS-FIXNUM vorg) 
    (ADD-INITIALIZATION "set-lowest-virtual-address"
			'(SYSTEM-INITIALIZE)
			'(:NOW :SYSTEM :HEAD-OF-LIST))))
)

(DEFUN USE-LAM-DIRECT NIL
  (SETQ DIRECT-MODE NIL					;Change to "T" eventually
	WRITE-FUNCTION '%IO-SPACE-WRITE
	READ-FUNCTION '%IO-SPACE-READ)
    (SETQ COLOR (- 176700000 177000000)
	  MODE (+ COLOR 11000)
	  VMB  (+ MODE 1)
	  SRAM-DATA (+ MODE 2)
	  CON-REG (+ COLOR 16777)
	  CON-PROM (+ COLOR 17000)
	  VIDEO-BUFFER-BASE-ADDRESS (- 176300000 177000000))
    (SETQ VIDEO-BUFFER-BASE-VIRTUAL-ADDRESS 176300000)
    (SETQ VIDEO-BUFFER-BASE-VIRTUAL-ADDRESS-AS-FIXNUM (si:%make-pointer-unsigned VIDEO-BUFFER-BASE-VIRTUAL-ADDRESS)))

(DEFUN USE-LAM NIL
  (SETQ DIRECT-MODE NIL
	WRITE-FUNCTION 'WORD-WRITE
	READ-FUNCTION 'WORD-READ
	UNIBUS-READ-FUNCTION NIL
	UNIBUS-WRITE-FUNCTION NIL
;These are all word addresses:
	COLOR 	  17760000
	MODE 	  17771000
	VMB	  17771001
	SRAM-DATA 17771002
	CON-REG   17776777
	CON-PROM  17777000
	VIDEO-BUFFER-BASE-ADDRESS 0))
;These are the byte addresses--(ash address -2) converts it into a word address:
;	COLOR 	  77700000
;	MODE 	  77744000
;	VMB	  77744004
;	SRAM-DATA 77744010
;	CON-REG   77773774
;	CON-PROM  77774000
;	VIDEO-BUFFER-BASE-ADDRESS 0))

(DEFUN USE-DIRECT NIL
  (ferror nil "this loses")
  (SETQ DIRECT-MODE NIL					;Leave this NIL till memory mapping works
	WRITE-FUNCTION 'WORD-WRITE
	READ-FUNCTION 'WORD-READ
	UNIBUS-READ-FUNCTION NIL
	UNIBUS-WRITE-FUNCTION NIL
;These are the byte addresses--(ash address -2) converts it into a word address:
	COLOR 	  77700000			;256. x 24. bits 0BGR
	MODE 	  77744000			;1 x 32.
	VMB	  77744004			;1 x 32.
	SRAM-DATA 77744010			;1 x 32.
	CON-REG   77773774			;1 x 32.
	CON-PROM  77774000			;512. 8.
	VIDEO-BUFFER-BASE-ADDRESS 0))		;128K x 32. (2 64's)

(DEFUN RUNNING-ON-LAMBDA? () T)

(DEFUN WORD-WRITE (WORD-ADDRESS DATA &OPTIONAL IGNORE-BUS-ERRORS)
  (SELECT SYS:PROCESSOR-TYPE-CODE
    (SI:CADR-TYPE-CODE
     (LAMBDA:ND-SLOT-WRITE LAMBDA:MEDIUM-COLOR-SLOT WORD-ADDRESS DATA IGNORE-BUS-ERRORS))
    (SI:LAMBDA-TYPE-CODE
     (%NUBUS-WRITE (DPB 17 #o0404 LAMBDA:MEDIUM-COLOR-SLOT)
		   (LSH WORD-ADDRESS 2)
		   DATA))))

(DEFUN WORD-READ (WORD-ADDRESS &OPTIONAL IGNORE-BUS-ERRORS)
  (SELECT SYS:PROCESSOR-TYPE-CODE
    (SI:CADR-TYPE-CODE
     (LAMBDA:ND-SLOT-READ LAMBDA:MEDIUM-COLOR-SLOT WORD-ADDRESS IGNORE-BUS-ERRORS))
    (SI:LAMBDA-TYPE-CODE
     (%NUBUS-READ (DPB 17 #o0404 LAMBDA:MEDIUM-COLOR-SLOT)
		   (LSH WORD-ADDRESS 2)))))

;THIS IS A TEMPORARY DEFINITION
;(SETQ MEDIUM-COLOR-SLOT 11)

;THIS IS A TEMPORARY DEFINITION
;(DEFUN WORD-WRITE (WORD-ADDRESS DATA)
;     (%NUBUS-WRITE (DPB 17 #o0404 MEDIUM-COLOR-SLOT) (LSH WORD-ADDRESS 2) DATA))

;THIS IS A TEMPORARY DEFINITION
;(DEFUN WORD-READ (WORD-ADDRESS)
;     (%NUBUS-READ (DPB 17 #o0404 MEDIUM-COLOR-SLOT) (LSH WORD-ADDRESS 2)))

(DEFUN BYTE-WRITE (BYTE-ADDRESS DATA &OPTIONAL IGNORE-BUS-ERRORS)
  (SELECT SYS:PROCESSOR-TYPE-CODE
    (SI:CADR-TYPE-CODE
     (LAMBDA:ND-SLOT-WRITE-BYTE LAMBDA:MEDIUM-COLOR-SLOT BYTE-ADDRESS DATA IGNORE-BUS-ERRORS))
    (SI:LAMBDA-TYPE-CODE
     (error "unimplemented"))))

(DEFUN HALFWORD-WRITE (HALFWORD-ADDRESS DATA &OPTIONAL IGNORE-BUS-ERRORS)
  (SELECT SYS:PROCESSOR-TYPE-CODE
    (SI:CADR-TYPE-CODE
     (LAMBDA:ND-SLOT-WRITE-HALFWORD LAMBDA:MEDIUM-COLOR-SLOT HALFWORD-ADDRESS DATA
				    IGNORE-BUS-ERRORS))
    (SI:LAMBDA-TYPE-CODE
     (error "unimplemented"))))

;IN CC, the address are set up to true physical addresses
(DEFUN USE-CC NIL
  (SETQ DIRECT-MODE NIL
	WRITE-FUNCTION 'CC:PHYS-MEM-WRITE
	READ-FUNCTION 'CC:PHYS-MEM-READ
	UNIBUS-READ-FUNCTION 'CC:DBG-READ
	UNIBUS-WRITE-FUNCTION 'CC:DBG-WRITE)
  (SET-BASE 17377530)
  (SETQ VIDEO-BUFFER-BASE-ADDRESS 15400000))

(DEFUN SET-BASE (BASE)
  (SETQ CONTROL-BASE-ADDRESS (+ BASE 0)
	MODE (+ CONTROL-BASE-ADDRESS 0)
	COLOR (+ CONTROL-BASE-ADDRESS 1)
	VMB (+ CONTROL-BASE-ADDRESS 2)
	SRAM-DATA (+ CONTROL-BASE-ADDRESS 3)))

(DEFUN READ-GPIO ()
  (FUNCALL UNIBUS-READ-FUNCTION 764126))

(DEFUN WRITE-GPIO (DATA)
  (FUNCALL UNIBUS-WRITE-FUNCTION 764126 DATA))

(DEFUN READ-MOUSE-X ()
  (LOGAND (FUNCALL UNIBUS-READ-FUNCTION 764106) 7777))

(DEFUN READ-MOUSE-Y ()
  (LOGAND (FUNCALL UNIBUS-READ-FUNCTION 764104) 7777))

(DEFUN READ-MOUSE-BUTTONS ()
 (LSH (LOGAND (FUNCALL UNIBUS-READ-FUNCTION 764104) 70000) -12.))

(DEFUN WRITE-MODE (DATA)				;Use this to write mode register
  (FUNCALL WRITE-FUNCTION MODE (SETQ MODE-REG DATA))
  NIL)

(DEFUN READ-MODE ()					;This just returns the software copy
  MODE-REG)

(DEFUN READ-STATUS ()					;STATUS has the same adr as MODE
  (FUNCALL READ-FUNCTION MODE))

(DEFUN READ-CON-PROM (ADR)
  (FUNCALL READ-FUNCTION (+ CON-PROM ADR)))

(DEFUN INIT (&OPTIONAL (OBJ SRAM-OBJECT))
  (WRITE-MODE 0)
  (CLEAR-COLOR-MAP)
  (LOAD-SRAM OBJ)
  (CLR-SRAM-ADR))

(DEFUN START (&OPTIONAL (CHAN 0) (XTAL-CLK T))
  (WRITE-MODE (IF XTAL-CLK (DPB CHAN 1402 44000241)	;Vertical step size = 144.
		(DPB CHAN 1402 44000242))))		;Select camera channel CHAN

(DEFUN LOAD-VMB (&OPTIONAL (DATA 0))
  (FUNCALL WRITE-FUNCTION VMB DATA))

(DEFUN WRITE-MASK (DATA)
  (WRITE-MODE (DPB DATA 3010 MODE-REG)))

(DEFUN DOWN-LOAD (&OPTIONAL (OBJECT SRAM-OBJECT))
  (INIT OBJECT)
  (START)
  (LOAD-VMB)
  (STRAIGHT-MAP))

(DEFUN SINGLE-STEP (&OPTIONAL (NUMBER-OF-STEPS 1))	;**useless
  (WRITE-MODE 0)
  (DO ((N 0 (1+ N)))
      ((= N NUMBER-OF-STEPS))
    (WRITE-MODE 10)
    (WRITE-MODE 0)))

(DEFUN STEP-LOOP (&OPTIONAL (COUNT 1))
  (DO () (())
    (TYI)
    (SINGLE-STEP COUNT)))

(DEFUN START-SQUARE ()
  (WRITE-MODE 40000241))				;Vertical step size = 128.

(DEFUN START-CAMERA (CHAN)				;**useless
  (WRITE-MODE (DPB CHAN 1402 44000201)))		;Vertical step size = 144.

(DEFUN GRAB-SQUARE ()					;**useless
    (WRITE-MODE 40000201))

(DEFUN CLEAR-VERT-FLAG ()
  (WRITE-MODE (LOGIOR 4000 MODE-REG))		;Clear VERT FLAG
  (WRITE-MODE (LOGXOR 4000 MODE-REG)))

(DEFUN WAIT-FOR-VSYNC ()
  (CLEAR-VERT-FLAG)				;Clear VERT FLAG
  (DO ()						;Wait for VERT FLAG
      ((BIT-TEST 1 (FUNCALL READ-FUNCTION MODE)))))

(DEFUN GRAB-FRAME (&OPTIONAL (CHAN 0) (MASK 0) (SCAN-MODE NIL) (EXT-SYNC NIL))
  (IF (NOT SCAN-MODE)					;test SCAN-MODE flag
      (COND ((NOT EXT-SYNC)
	     (WRITE-MODE (DPB CHAN 1402 44000201))	;Enter FG MODE
	     (TYI)
	     (WRITE-MODE (DPB CHAN 1402 44000241)))	;Back to TV MODE
	    (T
	     (WRITE-MODE (DPB MASK 3010
			      (DPB CHAN 1402 44001202)));Enter FG MODE, externally sync'ed
	     (TYI)
	     (WAIT-FOR-VSYNC)
	     (WRITE-MODE (DPB MASK 3010			;Back to TV MODE, externally sync'ed
			      (DPB CHAN 1402 44001242)));and still masked.
	     (WAIT-FOR-VSYNC)				;When sure frame grabbing has stopped
	     (WRITE-MODE (DPB CHAN 1402 44001242))))	;clear mask field.
    
    (COND ((NOT EXT-SYNC)				;SCAN-MODE flag is set
	   (WRITE-MODE (DPB CHAN 1402 44100201))	;Enter FG MODE
	   (TYI)
	   (WRITE-MODE (DPB CHAN 1402 44100241)))	;Back to TV MODE
	  (T
	   (WRITE-MODE (DPB MASK 3010
			    (DPB CHAN 1402 44101202)))	;Enter FG MODE, externally sync'ed
	   (TYI)
	   (WAIT-FOR-VSYNC)
	   (WRITE-MODE (DPB MASK 3010			;Back to TV MODE, externally sync'ed
			    (DPB CHAN 1402 44101242)))	;and still masked.
	   (WAIT-FOR-VSYNC)				;When sure frame grabbing has stopped
	   (WRITE-MODE (DPB CHAN 1402 44101242))))))	;clear mask field.

(DEFUN GRAB-FRAMES (&OPTIONAL (CHAN 0) (MASK 0) (SCAN-MODE NIL) (EXT-SYNC NIL))
  (FORMAT:OUTPUT T (TERPRI) "Hit the space bar to toggle mode, CR to exit." (TERPRI))
  (DO ()((= #\RETURN (TYI)))				;"Carriage return" to exit
    (GRAB-FRAME CHAN MASK SCAN-MODE EXT-SYNC))
  (PROCESS-SLEEP 10.)
  (START CHAN))						;Be sure XTAL CLOCK is on

(DEFUN BLT (FROM-ARRAY TO-ARRAY)
  (BITBLT TV:ALU-SETA 576. 454. FROM-ARRAY 0 0 TO-ARRAY 0 0))

(DEFUN SAVE-IMAGE (ARRAY FILENAME)
  (COMPILER:FASD-SYMBOL-VALUE FILENAME ARRAY))

(DEFUN MUX-LOOP (CHANNELS  &OPTIONAL (INTERVAL 60.))
  (DO-FOREVER
    (DOTIMES (N CHANNELS)
      (WAIT-FOR-VSYNC)
      (START-CAMERA N)
      (PROCESS-SLEEP INTERVAL))))


;;;;RAM RELATED FUNCTIONS

(DEFUN SLICE-X (ARRAY Y &AUX VALUE)
  (DO ((X 0 (+ X 4)))
      ((= X 576.))
    (SETQ VALUE (READ-RAM (+ (* 144. Y) (// X 4))))
    (ASET (LDB 0010 VALUE) ARRAY X)
    (ASET (LDB 1010 VALUE) ARRAY (+ 1 X))
    (ASET (LDB 2010 VALUE) ARRAY (+ 2 X))
    (ASET (LDB 3010 VALUE) ARRAY (+ 3 X)))
  ARRAY)

(DEFUN CLEAR ()
  (FILLARRAY GREY-SCREEN-ARRAY NIL))

(DEFUN WRITE-RAM (ADR DATA)
  (FUNCALL WRITE-FUNCTION (+ ADR VIDEO-BUFFER-BASE-ADDRESS) DATA)
  NIL)

(DEFUN READ-RAM (ADR)
  (FUNCALL READ-FUNCTION (+ ADR VIDEO-BUFFER-BASE-ADDRESS)))

;The following seems wrong. How could it have worked??        |
;(DEFUN WRITE-PLANE (ADR DATA &OPTIONAL (PLANE 0))    ;       V
;  (FUNCALL WRITE-FUNCTION (+ ADR VIDEO-BUFFER-BASE-ADDRESS 200000 (* PLANE 20000)) DATA)
;  NIL)
;
;(DEFUN READ-PLANE (ADR &OPTIONAL (PLANE 0))
;  (FUNCALL READ-FUNCTION (+ ADR VIDEO-BUFFER-BASE-ADDRESS 200000 (* PLANE 20000))))

(DEFUN WRITE-PLANE (ADR DATA &OPTIONAL (PLANE 0)) 
  (select-processor
    (:cadr
     (FUNCALL WRITE-FUNCTION (+ ADR VIDEO-BUFFER-BASE-ADDRESS 1000000 (* PLANE 20000)) DATA))
    ((:lambda :explorer)
     (FUNCALL WRITE-FUNCTION (+ ADR VIDEO-BUFFER-BASE-ADDRESS 200000 (* PLANE 20000)) DATA)))
  NIL)

(DEFUN READ-PLANE (ADR DATA &OPTIONAL (PLANE 0)) 
  (select-processor
    (:cadr
     (FUNCALL READ-FUNCTION (+ ADR VIDEO-BUFFER-BASE-ADDRESS 1000000 (* PLANE 20000)) DATA))
    ((:lambda :explorer)
     (FUNCALL READ-FUNCTION (+ ADR VIDEO-BUFFER-BASE-ADDRESS 200000 (* PLANE 20000)) DATA)))
  NIL)

(DEFUN WRITE-AND-READ-RAM (ADR DATA)
  (WRITE-RAM ADR DATA)
  (FORMAT T "~%VALUE READ BACK = ~O"(READ-RAM ADR)))

(DEFUN READ-RAM-N-TIMES (ADR NUMBER-OF-TIMES)
  (DO ((N 0 (1+ N)))
      ((= N NUMBER-OF-TIMES))
  (FORMAT T "~%VALUE READ BACK = ~O"(READ-RAM ADR))))

(DEFUN WRITE-RAM-AND-READ-N-TIMES (ADR DATA NUMBER-OF-TIMES)
  (WRITE-RAM ADR DATA)
  (DO ((N 0 (1+ N)))
      ((= N NUMBER-OF-TIMES))
  (FORMAT T "~%VALUE READ BACK = ~O"(READ-RAM ADR))))

(DEFUN LOAD-RAM (DATA &OPTIONAL (OFFSET 0) (COUNT 200000))
  (DO ((N OFFSET (1+ N)) (LOOP-COUNT 0 (1+ LOOP-COUNT)))
      ((OR (= LOOP-COUNT COUNT) (= N 200000)))
    (WRITE-RAM N DATA)))

(DEFUN DUMP-RAM (&OPTIONAL (OFFSET 0) (COUNT 200000) &AUX D D0 D1 D2 D3)
  (DO ((N OFFSET (1+ N)) (LOOP-COUNT 0 (1+ LOOP-COUNT)))
      ((OR (= LOOP-COUNT COUNT) (= N 200000)))
    (SETQ D (READ-RAM N) D0 (LOGAND 377 D) D1 (ASH (LOGAND 177400 D) -8.)
	  D2 (ASH (LOGAND 77600000 D) -16.) D3 (ASH (LOGAND 37700000000 D) -24.))
    (FORMAT T "~%LOCATION ~6O = ~12O  -  ~2,8,48R ~2,8,48R ~2,8,48R ~2,8,48R"
	    N D D3 D2 D1 D0)))

(DEFUN LOAD-PLANE (DATA &OPTIONAL (OFFSET 0) (COUNT 20000) (PLANE 0))
  (DO ((N OFFSET (1+ N)) (LOOP-COUNT 0 (1+ LOOP-COUNT)))
      ((OR (= LOOP-COUNT COUNT) (= N 20000)))
    (WRITE-PLANE N DATA PLANE)))

(DEFUN UNLOAD-PLANE (DATA &OPTIONAL (OFFSET 0) (COUNT 20000) (PLANE 0) &AUX D)
  (DO ((N OFFSET (1+ N)) (LOOP-COUNT 0 (1+ LOOP-COUNT)))
      ((OR (= LOOP-COUNT COUNT) (= N 20000)))
    (SETQ D (READ-PLANE N PLANE))
    (COND ((NOT (= DATA D))
	   (FORMAT T "~%LOCATION ~O READS ~O -- DIFFERENCE = ~O"
		   N D (- DATA D))))))

(DEFUN CLEAR-PLANE (PLANE)
  (LOAD-PLANE 0 0 20000 PLANE))

(DEFUN CLEAR-ARRAY (ARRAY)
  (BITBLT TV:ALU-XOR 576. 454. ARRAY 0 0 ARRAY 0 0))

(DEFUN RAMP ()
  (DO ((Y 0 (1+ Y)))
      ((= Y 454.))
    (DO ((X 0 (1+ X)) (A 0 (+ 2 A)))
	((= X 128.))
      (WRITE-RAM (+ X (* Y 144.))
	        (DPB A 0010 (DPB A 1010 (DPB (+ 1 A) 2010 (DPB (+ 1 A) 3010 0))))))
    (DO ((X 128. (1+ X)))
	((= X 144.))
      (WRITE-RAM (+ X (* Y 144.)) -1))))

(DEFUN SAWTOOTH ()
  (DO ((Y 0 (1+ Y)))
      ((= Y 454.))
    (DO ((X 0 (1+ X)) (A 0 (+ 2 A)))
	((= X 128.))
      (WRITE-RAM (+ X (* Y 144.))
	        (DPB A 0010 (DPB A 1010 (DPB (+ 1 A) 2010 (DPB (+ 1 A) 3010 0))))))
    (DO ((X 128. (1+ X)))
	((= X 144.))
      (WRITE-RAM (+ X (* Y 144.)) 0))))

;This is just a compressed grey scale peaking at 177
(DEFUN WEDGE ()
  (DO ((Y 0 (1+ Y)))
      ((= Y 454.))
    (DO ((X 0 (1+ X)) (A 0 (+ 2 A)))
	((= X 64.))
      (WRITE-RAM (+ X (* Y 144.))
	        (DPB (LOGAND A 176) 0010
		     (DPB (LOGAND A 176) 1010
			  (DPB (+ 1 (LOGAND A 176)) 2010
			       (DPB (+ 1 (LOGAND A 176)) 3010 0))))))
    (DO ((X 64. (1+ X)))
	((= X 144.))
      (WRITE-RAM (+ X (* Y 144.)) 0))))

(DEFUN SCALE ()
  (STRAIGHT-MAP)
  (SAWTOOTH))

(DEFUN SPECTRUM ()
  (IF (NOT DIRECT-MODE)
      (SPECTRAL-COLOR-MAP-IMMEDIATE)
    (SPECTRAL-COLOR-MAP))
  (RAMP))

(DEFUN LAMBDA-SPECTRUM ()
  (IF (NOT DIRECT-MODE)
      (LAMBDA-SPECTRAL-COLOR-MAP-IMMEDIATE)
    (SPECTRAL-COLOR-MAP))
  (RAMP))

(DEFUN WRITE-PATCH (D X XSIZE Y YSIZE &AUX DATA)
  (SETQ DATA (DPB D 0010 (DPB D 1010 (DPB D 2010 (DPB D 3010 0)))))
  (DO ((B (+ X (* Y 144.)) (+ B 144.)))
      ((>= B (* 144. (+ Y YSIZE))))
    (DO ((A B (1+ A)))
	((>= A (+ B XSIZE)))
      (WRITE-RAM A DATA))))

(DEFUN PALETTE  (&OPTIONAL (FILL 0) &AUX D)
  (SETQ D -1)
  (DO ((Y 0 (+ 28. Y)))
      ((>= Y 448.))
    (DO ((X 0 (+ X 9.)))
	((>= X 144.))
      (WRITE-PATCH (SETQ D (1+ D)) X 9. Y 28.)))
  (WRITE-PATCH FILL 0 144. 448. 6))

(DEFUN DRAW-FRAME ()
  (DOTIMES (N 144.)
    (WRITE-RAM N -1))
  (DO ((N 1 (1+ N)))
      ((>= N 453.))
    (WRITE-RAM (+ (* 144. N) 143.) 37700000000))
  (DOTIMES (N 145.)
    (WRITE-RAM (- (* 144. 454.) N) -1))
  (DO ((N 1 (1+ N)))
      ((>= N 453.))
    (WRITE-RAM (* 144. (- 453. N)) 377)))

(DEFUN CLEAR-FRAME ()
  (DOTIMES (N 144.)
    (WRITE-RAM N 0))
  (DO ((N 1 (1+ N)))
      ((>= N 453.))
    (WRITE-RAM (+ (* 144. N) 143.) 0))
  (DOTIMES (N 145.)
    (WRITE-RAM (- (* 144. 454.) N) 0))
  (DO ((N 1 (1+ N)))
      ((>= N 453.))
    (WRITE-RAM (* 144. (- 453. N)) 0)))

(DEFUN DRAW-GRID ()
  (DOTIMES (Y 449.)
    (COND ((= (LDB 0005 Y) 0)				;Multiples of 32. are solid
	   (DOTIMES (X 143.)
	     (WRITE-RAM (+ (* 144. Y) X) -1))
	   (WRITE-RAM (+ (* 144. Y) 143.) 377))
	   (T
	   (DOTIMES (X 9.)
	     (WRITE-RAM (+ (* 144. Y) (* 32. X)) 377))
	   (WRITE-RAM (+ (* 144. Y) 143.) 377)))))	;Others are dashed

(DEFUN CLEAR-GRID ()
  (DOTIMES (Y 449.)
    (COND ((= (LDB 0005 Y) 0)				;Multiples of 32. are solid
	   (DOTIMES (X 143.)
	     (WRITE-RAM (+ (* 144. Y) X) 0))
	   (WRITE-RAM (+ (* 144. Y) 143.) 0))
	   (T
	   (DOTIMES (X 9.)
	     (WRITE-RAM (+ (* 144. Y) (* 32. X)) 0))
	   (WRITE-RAM (+ (* 144. Y) 143.) 0)))))	;Others are dashed

;Following function is for pulling subarrays out of frame-grabber via diagnostic interface.
;TO-ARRAY is automatically created if it doesn't exist already.
(DEFUN DUMP-GREY-ARRAY (TO-ARRAY &OPTIONAL (FROM-X 36.) (FROM-Y 112.) &AUX D)
;  (IF (NOT (BOUNDP TO-ARRAY))
;      (SETQ TO-ARRAY (MAKE-ARRAY '(288. 227.) ':TYPE 'ART-8B)))
  (DOTIMES (Y 227.)
      (DOTIMES (X 72.)
	  (SETQ D (READ-RAM (+ (+ X FROM-X) (* (+ Y FROM-Y) 144.))))
	  (DOTIMES (I 4)
	    (AS-2-reverse (LDB 0010 D) TO-ARRAY (+ I (* X 4)) Y)
	    (SETQ D (ASH D -8))))))

;;;;RAM TESTS


(DEFUN RAM-TEST ()
  (IF DIRECT-MODE (FILLARRAY GREY-SCREEN-ARRAY NIL))
  (STRAIGHT-MAP)
  (OR (RAM-ADR-TEST)
      (RAM-DATA-TEST)
      (RAM-PLANE-ADR-TEST)
      (RAM-PLANE-DATA-TEST)))

(DEFUN RAM-FAST-ADR-TEST ()
  (FAST-ADR-TEST "RAM" 'READ-RAM 'WRITE-RAM 32. 16.))

(DEFUN RAM-ADR-TEST (&OPTIONAL ALREADY-LOADED &AUX D X FLAG)
  (SETQ FLAG NIL)
  (IF DIRECT-MODE (FILLARRAY GREY-SCREEN-ARRAY NIL))
  (COND ((NOT ALREADY-LOADED) 
	 (DO ((N 0 (1+ N)))
	     ((= N 65536.))
	   (WRITE-RAM N N))
	 (FORMAT T "~%RAM LOADED")))
  (DO ((N 0 (1+ N)))
      ((= 65536. N))
    (SETQ D (READ-RAM N))
    (SETQ X (LOGXOR D N))
    (COND ((NOT (= D N))
	   (FORMAT T "~%FAILING LOCATION ~6O GOT ~11O SHOULD BE ~11O DIFFERENCE ~11O" N D N X)
	   (SETQ FLAG T))))
  FLAG)

(DEFUN RAM-DATA-TEST (&AUX D ONES-READ-BACK FLAG)
  (COND (DIRECT-MODE
	 (FILLARRAY GREY-SCREEN-ARRAY NIL)
	 (SETQ ONES-READ-BACK -1))
	(T
	 (SETQ ONES-READ-BACK 37777777777)	;Put this back when memory mapping works.
;	 (SETQ ONES-READ-BACK -1)
	 ))
  (DO ((N 0 (1+ N)))
      ((= N 65536.))
    (WRITE-RAM N 0)
    (SETQ D (READ-RAM N))
    (COND ((NOT (= D 0))
	   (FORMAT T "~%FAILING LOCATION ~O GOT ~O SHOULD BE ~O"
		   N D 0)
	   (SETQ FLAG T)))
    (WRITE-RAM N 37777777777)
    (SETQ D (READ-RAM N))
    (COND ((NOT (= D ONES-READ-BACK))
	   (FORMAT T "~%FAILING LOCATION ~O GOT ~O SHOULD BE ~O"
		   N  D 37777777777)
	   (SETQ FLAG T))))
    FLAG)

(DEFUN RAM-PLANE-ADR-TEST (&OPTIONAL ALREADY-LOADED &AUX D A B FLAG)
  (IF DIRECT-MODE (FILLARRAY GREY-SCREEN-ARRAY NIL))
  (COND ((NOT ALREADY-LOADED) 
 	 (DO ((P 0 (1+ P)))
	     ((= P 10))
	   (DO ((N 0 (1+ N)))
	       ((= N 20000))
	     (SETQ A N)
	     (WRITE-PLANE N (DPB P 2203 A) P)))
	 (FORMAT T "~%RAM LOADED")))
  (DO ((P 0 (1+ P)))
      ((= P 10))
    (DO ((N 0 (1+ N)))
	((= N 20000))
      (SETQ A N)
      (SETQ D (READ-PLANE N P))
      (COND ((NOT (= D (SETQ B (DPB P 2203 A))))
	     (FORMAT T "~%PLANE ~O FAILING LOCATION ~6O GOT ~11O SHOULD BE ~11O" P N D B)
	     (SETQ FLAG T)))))
      FLAG)

(DEFUN RAM-PLANE-DATA-TEST (&AUX D 0&1-READ-BACK FLAG)
  (COND (DIRECT-MODE
	 (FILLARRAY GREY-SCREEN-ARRAY NIL)
	 (SETQ 0&1-READ-BACK -12525252526))
	(T
	 (SETQ 0&1-READ-BACK 25252525252)	;Put this back when memory mapping works.
;	 (SETQ 0&1-READ-BACK -12525252526)
	 ))
  (DO ((P 0 (1+ P)))
      ((= P 10))
    (DO ((N 0 (1+ N)))
	((= N 20000))
      (WRITE-PLANE N 0&1 P)
      (SETQ D (READ-PLANE N P))
      (COND ((NOT (= D 0&1-READ-BACK))
	     (FORMAT T "~%PLANE ~O FAILING LOCATION ~O GOT ~O SHOULD BE ~O"
		     P N D 0&1)
	     (SETQ FLAG T)))
      (WRITE-PLANE N 1&0 P)
      (SETQ D (READ-PLANE N P))
      (COND ((NOT (= D 1&0))
	     (FORMAT T "~%PLANE ~O FAILING LOCATION ~O GOT ~O SHOULD BE ~O"
		     P N D 1&0)
	     (SETQ FLAG T)))))
  FLAG)

(DEFUN OVERNIGHT-TEST ()
  (IF DIRECT-MODE (FILLARRAY GREY-SCREEN-ARRAY NIL))
  (STRAIGHT-MAP)
  (SETQ LOOP-COUNT 0)
  (SETQ AT-ERROR-COUNT 0)
  (SETQ DT-ERROR-COUNT 0)
  (SETQ PAT-ERROR-COUNT 0)
  (SETQ PDT-ERROR-COUNT 0)
  (DO-FOREVER
    (IF (RAM-ADR-TEST)
	(SETQ AT-ERROR-COUNT (+ 1 AT-ERROR-COUNT)))
    (IF (RAM-DATA-TEST)
	(SETQ DT-ERROR-COUNT (+ 1 DT-ERROR-COUNT)))
    (IF (RAM-PLANE-ADR-TEST)
	(SETQ PAT-ERROR-COUNT (+ 1 PAT-ERROR-COUNT)))
    (IF (RAM-PLANE-DATA-TEST)
	(SETQ PDT-ERROR-COUNT (+ 1 PDT-ERROR-COUNT)))
    (SETQ LOOP-COUNT (+ LOOP-COUNT 1))))

(DEFUN PRINT-TEST-RESULTS ()
  (FORMAT T "~%ITERATIONS: ~O~%" LOOP-COUNT)
  (FORMAT T "ADDR ERRORS: ~O~%" AT-ERROR-COUNT)
  (FORMAT T "DATA ERRORS: ~O~%" DT-ERROR-COUNT)
  (FORMAT T "PLANE ADDR ERRORS: ~O~%" PAT-ERROR-COUNT)
  (FORMAT T "PLANE DATA ERRORS: ~O~%" PDT-ERROR-COUNT))

;;;;COLOR MAP RELATED FUNCTIONS

(DEFUN CADR-WRITE-COLOR-MAP-IMMEDIATE (LOC R G B)
  (FUNCALL WRITE-FUNCTION COLOR (DPB LOC 0014 (DPB (- 377 R) 1412 (DPB 0 2602 0))))
  (FUNCALL WRITE-FUNCTION COLOR (DPB LOC 0014 (DPB (- 377 G) 1412 (DPB 1 2602 0))))
  (FUNCALL WRITE-FUNCTION COLOR (DPB LOC 0014 (DPB (- 377 B) 1412 (DPB 2 2602 0))))
  NIL)

;(COND ((RUNNING-ON-LAMBDA?)
(DEFUN WRITE-COLOR-MAP-IMMEDIATE (LOC R G B)
  (FUNCALL WRITE-FUNCTION (+ COLOR (LOGAND 377 LOC)) (DPB B 2010 (DPB G 1010 R)))
  NIL)
; ))

;(COND ((RUNNING-ON-LAMBDA?)
(DEFUN READ-COLOR-MAP-IMMEDIATE (LOC &AUX TEMP LIST)
  (SETQ TEMP (FUNCALL READ-FUNCTION (+ COLOR (LOGAND 377 LOC))))
  (SETQ LIST (LIST (LDB 0010 TEMP) (LDB 1010 TEMP) (LDB 2010 TEMP)))
  LIST)
;))

;(COND ((NOT (RUNNING-ON-LAMBDA?))
(DEFUN LOAD-COLOR-MAP (DATA RGB)
  (DO ((N 0 (+ 1 N)))
      ((= N 256.))
    (FUNCALL WRITE-FUNCTION COLOR (DPB N 0014 (DPB DATA 1412 (DPB RGB 2602 0))))))
;))

(DEFUN CLEAR-COLOR-MAP ()
  (LOAD-COLOR-MAP 377 0)
  (LOAD-COLOR-MAP 377 1)
  (LOAD-COLOR-MAP 377 2))

(DEFUN WRITE-COLOR-MAP (LOC R G B
                        &OPTIONAL (SYNCHRONIZE NIL) (SCREEN GREY-SCREEN)
                        &AUX (TV-ADR (TV:SCREEN-CONTROL-ADDRESS SCREEN))
			(HARDWARE-COLOR-MAP (GET (LOCF (TV:SCREEN-PROPERTY-LIST SCREEN))
						 ':HARDWARE-COLOR-MAP)))
  (select-processor
    (:cadr
      (SETQ LOC (LOGAND LOC 377)
	    R (- 377 (LOGAND (FIX R) 377))
	    G (- 377 (LOGAND (FIX G) 377))
	    B (- 377 (LOGAND (FIX B) 377)))
      (cond (SYNCHRONIZE
	     (PROG NIL
		   (%XBUS-WRITE MODE (LOGIOR 4000 MODE-REG))
		   (%XBUS-WRITE MODE MODE-REG)
		A (COND ((GREATERP (LOGAND 1 (%XBUS-READ TV-ADR)) 0)
			 (RETURN NIL)))
		   (GO A))))
      (COMPILER:%XBUS-WRITE-SYNC COLOR (DPB R 1412 LOC) 0 TV-ADR 2 2)
      (COMPILER:%XBUS-WRITE-SYNC COLOR (DPB G 1412 (DPB 1 2602 LOC)) 0 TV-ADR 2 2)
      (COMPILER:%XBUS-WRITE-SYNC COLOR (DPB B 1412 (DPB 2 2602 LOC)) 0 TV-ADR 2 2)
      (AS-2-REVERSE (- 377 R) HARDWARE-COLOR-MAP LOC 0)
      (AS-2-REVERSE (- 377 G) HARDWARE-COLOR-MAP LOC 1)
      (AS-2-REVERSE (- 377 B) HARDWARE-COLOR-MAP LOC 2))
    ((:lambda :explorer)
     (SETQ LOC (LOGAND LOC 377)
	   R (LOGAND (FIX R) 377)
	   G (LOGAND (FIX G) 377)
	   B (LOGAND (FIX B) 377))
     (%IO-SPACE-WRITE (+ COLOR (LOGAND 377 LOC)) (DPB B 2010 (DPB G 1010 R)))
     (AS-2-REVERSE R HARDWARE-COLOR-MAP LOC 0)
     (AS-2-REVERSE G HARDWARE-COLOR-MAP LOC 1)
     (AS-2-REVERSE B HARDWARE-COLOR-MAP LOC 2))))


(DEFUN READ-COLOR-MAP (LOC &OPTIONAL (SCREEN GREY-SCREEN))
  (PROG ((LOC (LOGAND LOC 377))
         (HARDWARE-COLOR-MAP (GET (LOCF (TV:SCREEN-PROPERTY-LIST SCREEN))
				  ':HARDWARE-COLOR-MAP)))
    (RETURN (AR-2-REVERSE HARDWARE-COLOR-MAP LOC 0)
            (AR-2-REVERSE HARDWARE-COLOR-MAP LOC 1)
            (AR-2-REVERSE HARDWARE-COLOR-MAP LOC 2))))

(DEFUN STRAIGHT-MAP (&OPTIONAL SHOW-SATURATION-FLAG)
  (COND ((NOT DIRECT-MODE)			;if using diagnostic interface, avoid
	 (DOTIMES (N 256.)			;window system code
	   (WRITE-COLOR-MAP-IMMEDIATE N N N N))
	 (COND (SHOW-SATURATION-FLAG
		(WRITE-COLOR-MAP-IMMEDIATE 0 0 0 255.)
		(WRITE-COLOR-MAP-IMMEDIATE 255. 255. 0 0))))
	(T
	 (DOTIMES (N 256.)
	   (WRITE-COLOR-MAP N N N N))



	 (COND (SHOW-SATURATION-FLAG
		(WRITE-COLOR-MAP 0 0 0 255.)
		(WRITE-COLOR-MAP 255. 255. 0 0))))))

(DEFUN IDENT-COLOR-MAP (&OPTIONAL SHOW-SATURATION-FLAG)
  (STRAIGHT-MAP SHOW-SATURATION-FLAG))

(DEFUN INVERSE-COLOR-MAP (&AUX D)
  (IF (NOT DIRECT-MODE)				;if using diagnostic interface, avoid
      (DOTIMES (N 256.)					;window system code
	(SETQ D (- 377 N))
	(WRITE-COLOR-MAP-IMMEDIATE N D D D))
    (DOTIMES (N 256.)
      (SETQ D (- 377 N))
      (WRITE-COLOR-MAP N D D D))))

;Following loads a straight-map with bit plane 0 reserved for an overlay.
(DEFUN SPECIAL-COLOR-MAP (&OPTIONAL (R 0) (G 377) (B 0))
  (STRAIGHT-MAP)
  (DO ((N 0 (+ 2 N)))
      ((= N 256.))
    (WRITE-COLOR-MAP (- 377 N) R G B)))

;use the color map to select a given plane
(DEFUN SELECT-PLANE (PLANE-NUMBER &OPTIONAL (R 377) (G 377) (B 377))
  (IF (NOT DIRECT-MODE)
      (LET ((PIXEL-BIT (LSH 1 PLANE-NUMBER)))
	(DO ((N 0 (1+ N)))
	    ((= N 256.))
	  (IF (BIT-TEST PIXEL-BIT N)
	      (WRITE-COLOR-MAP-IMMEDIATE N R G B)
	    (WRITE-COLOR-MAP-IMMEDIATE N 0 0 0))))
    (LET ((PIXEL-BIT (LSH 1 PLANE-NUMBER)))
      (DO ((N 0 (1+ N)))
	  ((= N 256.))
	(IF (BIT-TEST PIXEL-BIT N)
	    (WRITE-COLOR-MAP N R G B)
	  (WRITE-COLOR-MAP N 0 0 0))))))

(DEFUN SPECTRAL-COLOR-MAP (&AUX STEP MPI X)
  (SETQ MPI (ATAN 0 -1))
  (SETQ STEP (// MPI 256.))
  (DO ((N 0 (+ 1 N)))
      ((= N 256.))
    (SETQ X (* N STEP))
    (WRITE-COLOR-MAP N
		       (- 377 (FIXR (* 127. (- 1 (COS X)))))
		       (- 377 (FIXR (* 254. (- 1 (SIN X)))))
		       (- 377 (FIXR (* 127. (+ 1 (COS X)))))
		       ))
  (WRITE-COLOR-MAP 0 0 0 0)
  (WRITE-COLOR-MAP 377 377 377 377))

(DEFUN SPECTRAL-COLOR-MAP-IMMEDIATE (&AUX STEP MPI X)
  (SETQ MPI (ATAN 0 -1))
  (SETQ STEP (// MPI 256.))
  (DO ((N 0 (+ 1 N)))
      ((= N 256.))
    (SETQ X (* N STEP))
    (WRITE-COLOR-MAP-IMMEDIATE N
		       (FIXR (* 127. (- 1 (COS X))))
		       (FIXR (* 254. (- 1 (SIN X))))
		       (FIXR (* 127. (+ 1 (COS X))))
		       ))
  (WRITE-COLOR-MAP-IMMEDIATE 377 0 0 0)
  (WRITE-COLOR-MAP-IMMEDIATE 0 377 377 377))

(DEFUN LAMBDA-SPECTRAL-COLOR-MAP-IMMEDIATE (&AUX STEP MPI X)
  (SETQ MPI (ATAN 0 -1))
  (SETQ STEP (// MPI 256.))
  (DO ((N 0 (+ 1 N)))
      ((= N 256.))
    (SETQ X (* N STEP))
    (WRITE-COLOR-MAP-IMMEDIATE N
		       (- 377 (FIXR (* 127. (- 1 (COS X)))))
		       (- 377 (FIXR (* 254. (- 1 (SIN X)))))
		       (- 377 (FIXR (* 127. (+ 1 (COS X)))))
		       ))
  (WRITE-COLOR-MAP-IMMEDIATE 0 0 0 0)
  (WRITE-COLOR-MAP-IMMEDIATE 377 377 377 377))

;;;;COLOR MAP TESTS(LAMBDA)

;(COND ((RUNNING-ON-LAMBDA?)
(DEFUN COLOR-MAP-ADR-TEST (&OPTIONAL ALREADY-LOADED &AUX D R G B X FLAG)
  (SETQ FLAG NIL)
  (COND ((NOT ALREADY-LOADED) 
	 (DO ((N 0 (1+ N)))
	     ((= N 256.))
	   (WRITE-COLOR-MAP-IMMEDIATE N N N N))
	 (FORMAT T "~%COLOR MAP LOADED")))
  (DO ((N 0 (1+ N)))
      ((= 256. N))
    (SETQ D (READ-COLOR-MAP-IMMEDIATE N))
    (SETQ R (FIRST D) G (SECOND D) B (THIRD D))
    (SETQ D (DPB B 2010 (DPB G 1010 R)))
    (SETQ X (DPB N 2010 (DPB N 1010 N)))
    (COND ((NOT (= D X))
	   (FORMAT T "~%FAILING LOCATION ~6O GOT ~3O SHOULD BE ~3O" N D X)
	   (SETQ FLAG T))))
  FLAG)

(DEFUN COLOR-MAP-DATA-TEST (&AUX D R G B FLAG)
  (SETQ FLAG NIL)
  (DO ((N 0 (1+ N)))
      ((= N 256.))
    (WRITE-COLOR-MAP-IMMEDIATE N 0 0 0)
    (SETQ D (READ-COLOR-MAP-IMMEDIATE N))
    (SETQ R (FIRST D) G (SECOND D) B (THIRD D))
    (SETQ D (DPB B 2010 (DPB G 1010 R)))
    (COND ((NOT (= D 0))
	   (FORMAT T "~%FAILING LOCATION ~O GOT ~O SHOULD BE ~O"
		   N D 0)
	   (SETQ FLAG T)))
    (WRITE-COLOR-MAP-IMMEDIATE N 377 377 377)
    (SETQ D (READ-COLOR-MAP-IMMEDIATE N))
    (SETQ R (FIRST D) G (SECOND D) B (THIRD D))
    (SETQ D (DPB B 2010 (DPB G 1010 R)))
    (COND ((NOT (= D 77777777))
	   (FORMAT T "~%FAILING LOCATION ~O GOT ~O SHOULD BE ~O"
		   N  D 77777777)
	   (SETQ FLAG T))))
  FLAG)
;))


;;;;FUNCTIONS FOR INTERACTIVE USE


(DEFUN R (ADR)
  (READ-RAM ADR))
  
(DEFUN W (ADR DATA)
  (WRITE-RAM ADR DATA)
  NIL)
  
(DEFUN RN (ADR &OPTIONAL (COUNT 10))
  (READ-RAM-N-TIMES ADR COUNT))

(DEFUN RP (ADR &OPTIONAL (PLANE 0))
  (READ-PLANE ADR PLANE))
  
(DEFUN WP (ADR DATA &OPTIONAL (PLANE 0))
  (WRITE-PLANE ADR DATA PLANE)
  NIL)
  
(DEFUN D (&OPTIONAL (OFFSET 0) (COUNT 8.))
  (DUMP-RAM OFFSET COUNT))
  
(DEFUN L (DATA &OPTIONAL (OFFSET 0) (COUNT 8.))
  (LOAD-RAM DATA OFFSET COUNT))

(DEFUN WAR (ADR DATA &OPTIONAL (COUNT 10))
  (WRITE-RAM-AND-READ-N-TIMES ADR DATA COUNT))

(DEFUN SM ()
  (STRAIGHT-MAP))

(DEFUN LVB (&OPTIONAL (DATA 0))
  (LOAD-VMB DATA))

;;;;MISC DIAGNOSTIC FUNCTIONS


(DEFUN WRITE-EVEN-LINES (DATA)
  (DO ((N 0 (+ N 2)))
      ((>= N 454.))
    (DO ((M 0 (1+ M)))
	((>= M 144.))
      (WRITE-RAM (+ M (* 144. N)) DATA))))

(DEFUN WRITE-ODD-LINES (DATA)
  (DO ((N 1 (+ N 2)))
      ((>= N 454.))
    (DO ((M 0 (1+ M)))
	((>= M 144.))
      (WRITE-RAM (+ M (* 144. N)) DATA))))