;;;
;;; sib-graphics.lisp
;;;
;;; graphics framebuffer emulation on the SIB board.
;;;

(in-package :nevermore)

(declaim (type (simple-array (unsigned-byte 8) (*)) *sib-framebuffer*))
(defvar *sib-framebuffer* (make-array '(#x20000) :element-type '(unsigned-byte 8)
				      :initial-element 0))

(declaim (type (simple-array (unsigned-byte 32) ()) *sib-graphics-mask-register*))
(defvar *sib-graphics-mask-register* (make-array () :element-type '(unsigned-byte 32)
						 :initial-element 0))

(defvar *sib-graphics-logical-operation* 0)

(defun sib-graphics-read (address width)
  (setf *inhibit-nubus-trace* t)
  (cond ((eq width :byte)
	 (setf (aref *memory-data*)
	       (dpb (aref *sib-framebuffer* address)
		    (byte 8 (* 8 (logand 3 address)))
		    0)))
	((eq width :half)
	 (setf (aref *memory-data*)
	       (dpb (aref *sib-framebuffer* (1+ address))
		    (byte 8 (* 8 (1+ (logand 2 address))))
		    (dpb (aref *sib-framebuffer* address)
			 (byte 8 (* 8 (logand 2 address)))
			 0))))
	((eq width :word)
	 (setf (aref *memory-data*)
	       (dpb (aref *sib-framebuffer* (+ address 3)) (byte 8 24)
		    (dpb (aref *sib-framebuffer* (+ address 2)) (byte 8 16)
			 (dpb (aref *sib-framebuffer* (+ address 1)) (byte 8 8)
			      (aref *sib-framebuffer* address))))))
	(t (error "Bogus width")))
  (values))

(defun sib-graphics-write (address width)
  (setf *inhibit-nubus-trace* t)
  (cond ((eq width :byte)
	 (setf (aref *sib-framebuffer* address)
	       (ldb (byte 8 (* 8 (logand 3 address)))
		    (aref *memory-data*))))
	((eq width :half)
	 (setf (aref *sib-framebuffer* (+ address 1))
	       (ldb (byte 8 (* 8 (1+ (logand 2 address))))
		    (aref *memory-data*)))
	 (setf (aref *sib-framebuffer* (+ address 0))
	       (ldb (byte 8 (* 8 (logand 2 address)))
		    (aref *memory-data*))))
	((eq width :word)
	 (setf (aref *sib-framebuffer* (+ address 3))
	       (ldb (byte 8 24) (aref *memory-data*)))
	 (setf (aref *sib-framebuffer* (+ address 2))
	       (ldb (byte 8 16) (aref *memory-data*)))
	 (setf (aref *sib-framebuffer* (+ address 1))
	       (ldb (byte 8  8) (aref *memory-data*)))
	 (setf (aref *sib-framebuffer* (+ address 0))
	       (ldb (byte 8  0) (aref *memory-data*))))
	(t (error "Bogus width")))
  (values))

(declaim (type (simple-array (function) (*)) *sib-logical-operations*))
(defvar *sib-logical-operations* (make-array '(#x10)))

#|
;; Old version
(setf (aref *sib-logical-operations*  0) #'(lambda (d s) (declare (ignorable d s)) 0))
(setf (aref *sib-logical-operations*  1) #'(lambda (d s)                           (lognor d s)))
(setf (aref *sib-logical-operations*  2) #'(lambda (d s)                           (logand s (logxor #xff d))))
(setf (aref *sib-logical-operations*  3) #'(lambda (d s) (declare (ignorable   s)) (logxor #xff d)))
(setf (aref *sib-logical-operations*  4) #'(lambda (d s)                           (logand d (logxor #xff s))))
(setf (aref *sib-logical-operations*  5) #'(lambda (d s) (declare (ignorable d  )) (logxor #xff s)))
(setf (aref *sib-logical-operations*  6) #'(lambda (d s)                           (logxor d s)))
(setf (aref *sib-logical-operations*  7) #'(lambda (d s)                           (lognand d s)))
(setf (aref *sib-logical-operations*  8) #'(lambda (d s)                           (logand d s)))
(setf (aref *sib-logical-operations*  9) #'(lambda (d s)                           (logxor #xff (logxor d s))))
(setf (aref *sib-logical-operations* 10) #'(lambda (d s) (declare (ignorable d  )) s))
(setf (aref *sib-logical-operations* 11) #'(lambda (d s)                           (logior s (logxor #xff d))))
(setf (aref *sib-logical-operations* 12) #'(lambda (d s) (declare (ignorable   s)) d))
(setf (aref *sib-logical-operations* 13) #'(lambda (d s)                           (logior d (logxor #xff s))))
(setf (aref *sib-logical-operations* 14) #'(lambda (d s)                           (logior d s)))
(setf (aref *sib-logical-operations* 15) #'(lambda (d s) (declare (ignorable d s)) #xff))
|#

;; New version
(setf (aref *sib-logical-operations*  0) #'(lambda (d s) (logand #xff (boole boole-clr   d s))))
(setf (aref *sib-logical-operations*  1) #'(lambda (d s) (logand #xff (boole boole-nor   d s))))
(setf (aref *sib-logical-operations*  2) #'(lambda (d s) (logand #xff (boole boole-andc1 d s))))
(setf (aref *sib-logical-operations*  3) #'(lambda (d s) (logand #xff (boole boole-c1    d s))))
(setf (aref *sib-logical-operations*  4) #'(lambda (d s) (logand #xff (boole boole-andc2 d s))))
(setf (aref *sib-logical-operations*  5) #'(lambda (d s) (logand #xff (boole boole-c2    d s))))
(setf (aref *sib-logical-operations*  6) #'(lambda (d s) (logand #xff (boole boole-xor   d s))))
(setf (aref *sib-logical-operations*  7) #'(lambda (d s) (logand #xff (boole boole-nand  d s))))
(setf (aref *sib-logical-operations*  8) #'(lambda (d s) (logand #xff (boole boole-and   d s))))
(setf (aref *sib-logical-operations*  9) #'(lambda (d s) (logand #xff (boole boole-eqv   d s))))
(setf (aref *sib-logical-operations* 10) #'(lambda (d s) (logand #xff (boole boole-2     d s))))
(setf (aref *sib-logical-operations* 11) #'(lambda (d s) (logand #xff (boole boole-orc1  d s))))
(setf (aref *sib-logical-operations* 12) #'(lambda (d s) (logand #xff (boole boole-1     d s))))
(setf (aref *sib-logical-operations* 13) #'(lambda (d s) (logand #xff (boole boole-orc2  d s))))
(setf (aref *sib-logical-operations* 14) #'(lambda (d s) (logand #xff (boole boole-ior   d s))))
(setf (aref *sib-logical-operations* 15) #'(lambda (d s) (logand #xff (boole boole-set   d s))))

(defun sib-perform-logical-operation (d s m)
  (let ((r (funcall (aref *sib-logical-operations*
			  (logand #x0f *sib-graphics-logical-operation*))
		    d s)))
    (logior (logand d m)
	    (logand r (logxor m #xff)))))

(defun sib-graphics-read-modify-write (address width)
  (cond ((eq width :byte)
	 (setf (aref *sib-framebuffer* address)
	       (sib-perform-logical-operation
		(aref *sib-framebuffer* address)
		(ldb (byte 8 (* 8 (logand 3 address)))
		     (aref *memory-data*))
		(ldb (byte 8 (* 8 (logand 3 address)))
		     (aref *sib-graphics-mask-register*)))))
	((eq width :half)
	 (setf (aref *sib-framebuffer* address)
	       (sib-perform-logical-operation
		(aref *sib-framebuffer* address)
		(ldb (byte 8 (* 8 (logand 2 address)))
		     (aref *memory-data*))
		(ldb (byte 8 (* 8 (logand 2 address)))
		     (aref *sib-graphics-mask-register*))))
	 (setf (aref *sib-framebuffer* (1+ address))
	       (sib-perform-logical-operation
		(aref *sib-framebuffer* (1+ address))
		(ldb (byte 8 (* 8 (1+ (logand 2 address))))
		     (aref *memory-data*))
		(ldb (byte 8 (* 8 (1+ (logand 2 address))))
		     (aref *sib-graphics-mask-register*)))))
	((eq width :word)
	 (setf (aref *sib-framebuffer* (+ address 3))
	       (sib-perform-logical-operation
		(aref *sib-framebuffer* (+ address 3))
		(ldb (byte 8 24) (aref *memory-data*))
		(ldb (byte 8 24) (aref *sib-graphics-mask-register*))))
	 (setf (aref *sib-framebuffer* (+ address 2))
	       (sib-perform-logical-operation
		(aref *sib-framebuffer* (+ address 2))
		(ldb (byte 8 16) (aref *memory-data*))
		(ldb (byte 8 16) (aref *sib-graphics-mask-register*))))
	 (setf (aref *sib-framebuffer* (+ address 1))
	       (sib-perform-logical-operation
		(aref *sib-framebuffer* (+ address 1))
		(ldb (byte 8  8) (aref *memory-data*))
		(ldb (byte 8  8) (aref *sib-graphics-mask-register*))))
	 (setf (aref *sib-framebuffer* (+ address 0))
	       (sib-perform-logical-operation
		(aref *sib-framebuffer* (+ address 0))
		(ldb (byte 8  0) (aref *memory-data*))
		(ldb (byte 8  0) (aref *sib-graphics-mask-register*)))))
	(t (error "Bogus width")))
  (values))

(declaim (type (simple-array t (*)) *sib-bmp-header*))
(defparameter *sib-bmp-header* #(#x42 #x4d #x3e #x94 1 0 0 0 0 0 #x3e 0 0 0 #x28 0 0 0 0 4 0 0 #x28 3 0 0 1 0 1 0 0 0 0 0 0 #x94 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #xff #xff #xff 0))

(defun sib-write-screenshot (filename)
  (with-open-file (imagefile filename :direction :output
			     :element-type '(unsigned-byte 8))
    (dotimes (i #x3e)
      (write-byte (aref *sib-bmp-header* i) imagefile))
    (dotimes (y 808)
      (dotimes (x 128)
	(let ((data (aref *sib-framebuffer* (+ x (* (- 807 y) 128)))))
	  (setf data (logior (ash (logand data #x55) 1)
			     (ash (logand data #xaa) -1)))
	  (setf data (logior (ash (logand data #x33) 2)
			     (ash (logand data #xcc) -2)))
	  (setf data (logior (ash (logand data #x0f) 4)
			     (ash (logand data #xf0) -4)))
	  
	  (write-byte data imagefile))))))

(defvar *sib-character-recognizer* ()
  "A property list matching a (unique) hash of the bitmap for a character to the character itself.")

(defun sib-init-character-recognizer ()
  "Initialize the character recognizer for the text screenshot system. May be dependant on SIB ROM version."
  (let ((foo ()))
    (dotimes (i 95)
      (let ((sum 0))
	(dotimes (j 12)
	  (incf sum (ash (aref *sib-config-rom* (+ #x19a9 (* i 12) j)) (- 11 j))))
	(push (code-char (+ #x20 i)) foo)
	(push sum foo)))
    (setf *sib-character-recognizer* foo))
  (values))

(declaim (inline sib-recognize-character))
(defun sib-recognize-character (x y)
  (let ((address (+ (* (+ (* 13 y) 8) 128) x 1))
	(sum 0))
    (dotimes (row 12)
      (incf sum (ash (aref *sib-framebuffer* (+ address (* row 128))) (- 11 row))))
    (getf *sib-character-recognizer* sum)))

(defun sib-text-screenshot ()
  (dotimes (y 61)
    (dotimes (x 126)
      (format t "~A" (sib-recognize-character x y)))
    (terpri)))

;;; EOF
