;; printing keycodes received on key press and release. running counter below left
;; new VGA
             
(setf *test-a2*
      
      '(let ()
       
         (defun not (x)
           (if x nil -1))

         (defun next-i (i m)
           (addr-and (%+ i 1) m))

         (defun mod-m (i m)
           (if (%>= i m)
               (%- i m)
             i))


         (defun p-shiftl (x i)
           (do ((j 0 (%+ j 1)))
               ((%>= j i) x)
             (setq x (p-shiftl-1 x))))

         (defun p-shiftr (x i)
           (do ((j 0 (%+ j 1)))
               ((%>= j i) x)
             (setq x (p-shiftr-1 x))))

         (defun irq (x)
           (let ((ch (get-word (p-constr 57344 0) 8))
                 (getpt (get-word 100 0))
                 (insrtpt (get-word 100 4)))
;             (%print ch)
;             (%print insrtpt)
             (set-word 110 insrtpt ch)
;             (%print -1)
;             (%print (get-word 110 insrtpt))
             (let ((insrtpt1 (next-i insrtpt 15)))
               (if (not (%= insrtpt1 getpt))
                   (set-word 100 4 insrtpt1)))
;             (%print (get-word 100 4))
             (let ((s (get-status)))
               (set-status (addr-ior s 128))
;               (%print (get-status))
               x)))

         (defun getch ()
           (let ((getpt (get-word 100 0))
                 (insrtpt (get-word 100 4)))
             (if (%= getpt insrtpt)
                 -1
               (let ((ch (get-word 110 getpt)))
                 (set-word 100 0 (next-i getpt 15))
                 ch))))


         (defun to-ascii (val)
           (if (%<= val 9)
               (%+ val 48)
             (%+ val 55)))

         (defun print-hex-digit (pos val)
           (set-byte base_vga (p-shiftl pos 2) (to-ascii val)))

         (defun print-hex-byte (pos val)
           (print-hex-digit (%+ pos 1) (addr-and val 15))
           (print-hex-digit pos (addr-and (tag-and (p-shiftr val 4) 0) 15)))


         (defun print-hex (pos val)
           (let ((v val))
             (print-hex-byte (%+ pos 6) (addr-and (p-shiftl val 2) 255))
             (print-hex-byte (%+ pos 4) (addr-and (setq v (tag-and (p-shiftr v 6) 0)) 255))
             (print-hex-byte (%+ pos 2) (addr-and (setq v (tag-and (p-shiftr v 8) 0)) 255))
             (print-hex-byte pos (addr-and (tag-and (p-shiftr v 8) 0) 255))))

         (set-word (p-constr 0 16) 0 (%symbol-function 'irq))


         (setq base_vga (p-constr 61440 0))
         (setq base_sram (p-constr 53248 0))
         (setq base_ctrl (p-constr 57344 0))

         (%print (tag-and (p-shiftr base_sram 14) 0))
         (%print (tag-and (p-shiftr (p-shiftl base_sram 16) 14) 0))

         (setq base_low (p-constr 0 0))

         (set-word 100 0 0) ; getpt
         (set-word 100 4 0) ; insrtpt

         (do ((out-pos 0 out-pos)
              (i 0 (%+ i 1)))
             (nil)
           (let ((ch (getch)))
             (print-hex 5320 i)
             (if (not (%= ch -1))
                 (progn 
                   (print-hex out-pos ch)
                   (setq out-pos (mod-m (%+ out-pos 19) 5320))))))))



;; %closure-ref, %svref, %set-svref, vector test
;; old VGA


(setf *test-a3*
      '(let ((a (%make-vector 10))
             (a1 (vector 100 200 300 400 500 600 700 800 900 1000))
             (c (%make-closure 100 111)))

         (setq base_vga (p-constr 61440 0))
         (setq base_sram (p-constr 53248 0))
         (setq base_ctrl (p-constr 57344 0))

         (defun p-shiftl (x i)
           (do ((j 0 (%+ j 1)))
               ((%>= j i) x)
             (setq x (p-shiftl-1 x))))

         (defun p-shiftr (x i)
           (do ((j 0 (%+ j 1)))
               ((%>= j i) x)
             (setq x (p-shiftr-1 x))))

         (defun to-ascii (val)
           (if (%<= val 9)
               (%+ val 48)
             (%+ val 55)))

         (defun print-hex-digit (pos val)
           (set-byte base_vga pos (to-ascii val)))

         (defun print-hex-byte (pos val)
           (print-hex-digit (%+ pos 1) (addr-and val 15))
           (print-hex-digit pos (addr-and (tag-and (p-shiftr val 4) 0) 15)))


         (defun print-hex (pos val)
           (let ((v val))
             (print-hex-byte (%+ pos 6) (addr-and (p-shiftl val 2) 255))
             (print-hex-byte (%+ pos 4) (addr-and (setq v (tag-and (p-shiftr v 6) 0)) 255))
             (print-hex-byte (%+ pos 2) (addr-and (setq v (tag-and (p-shiftr v 8) 0)) 255))
             (print-hex-byte pos (addr-and (tag-and (p-shiftr v 8) 0) 255))))




         (print-hex 0 (get-word c 8))
         (print-hex 133 (get-word c 12))
         (do ((i 0 (%+ i 1)))
             ((%>= i 10))
           (%set-svref a i (%+ i 17))
           (print-hex (%+ 266 (p-shiftl i 4)) (%svref a1 i)))
         (print-hex 3325 (%closure-ref c 0))
         (print-hex 3458 (%closure-ref c 1))
         (do ((j 0 (%+ j 1)))
             (nil)
           (set-byte base_ctrl 12 (addr-and j 255))
           (print-hex 5719 j))))


;; closures sharing write variable test
;; at the end accessing the LED block out-register
;; old VGA



(setf *test-a4* 
      '(let ((www 12))


         (setq base_vga (p-constr 61440 0))
         (setq base_sram (p-constr 53248 0))
         (setq base_ctrl (p-constr 57344 0))

         (defun p-shiftl (x i)
           (do ((j 0 (%+ j 1)))
               ((%>= j i) x)
             (setq x (p-shiftl-1 x))))

         (defun p-shiftr (x i)
           (do ((j 0 (%+ j 1)))
               ((%>= j i) x)
             (setq x (p-shiftr-1 x))))


         (defun to-ascii (val)
           (if (%<= val 9)
               (%+ val 48)
             (%+ val 55)))

         (defun print-hex-digit (pos val)
           (set-byte base_vga pos (to-ascii val)))

         (defun print-hex-byte (pos val)
           (print-hex-digit (%+ pos 1) (addr-and val 15))
           (print-hex-digit pos (addr-and (tag-and (p-shiftr val 4) 0) 15)))


         (defun print-hex (pos val)
           (let ((v val))
             (print-hex-byte (%+ pos 6) (addr-and (p-shiftl val 2) 255))
             (print-hex-byte (%+ pos 4) (addr-and (setq v (tag-and (p-shiftr v 6) 0)) 255))
             (print-hex-byte (%+ pos 2) (addr-and (setq v (tag-and (p-shiftr v 8) 0)) 255))
             (print-hex-byte pos (addr-and (tag-and (p-shiftr v 8) 0) 255))))

         (let ((x 1)(ff nil)) 

           (defun consx (x y)

             (let ((p (%reserve-space 8)))
               (set-word p 0 x)
               (set-word p 4 y)
               (tag-set p 1)))


           (let ((i 0) (ff1 nil))
             (setq ff1 (do-until ((%> i 5) ff)
                                 (let ((y 1))
                                   (setq i (%+ i 1))
                                   (setq ff (consx #'(lambda (z)
                                                       (cond ((%= z 0) x)
                                                             (1 (setq x z)))) ff)))))
             (print-hex 0 12)
             (print-hex 12 ff1)
             (print-hex 24 33)
             (print-hex 36 (funcall (car (cdr ff)) 22))
             (print-hex 48 (funcall (car ff) 0))
             (print-hex 60 (funcall (car (cdr (cdr ff))) 57))
             (print-hex 72 (funcall (car (cdr ff)) 0))
             
             (setq v -1)

             (do ((i 0 (%+ i 1)))
                 (nil)
               (print-hex 266 i)
               (if (%= i 128000) (setq i 0))
               (if (%= i 127999) (set-word (p-constr 57344 0) 12 (%+ 1984 (setq v (%+ v 1))))))))))


;; the basic column printer memory move test
;; new VGA


(setf *test-a6*
      
      '(let ()
       
         (defun p-shiftl (x i)
           (do ((j 0 (%+ j 1)))
               ((%>= j i) x)
             (setq x (p-shiftl-1 x))))

         (defun p-shiftr (x i)
           (do ((j 0 (%+ j 1)))
               ((%>= j i) x)
             (setq x (p-shiftr-1 x))))

  
         (defun mul (a b)
           (let ((acc 0)
                 (i 32))
             (do-until ((%= i 0) acc)
                       (if (%= (tag-and (addr-and b 1) 0) 1)
                           (setq acc (%+ acc a)))
                       (setq b (p-shiftr-1 b))
                       (setq a (p-shiftl-1 a))
                       (setq i (%- i 1)))))

         (defun irq (x)
           (progn
             (do ((i 0 (%+ i 1)))
                 ((%>= i 44))
               (set-byte base_vga (%+ (p-shiftl (%+ 532 i) 2) 1) 1))
             (%print (get-word (p-constr 57344 0) 8))
             (let ((s (get-status)))
               (set-status (addr-ior s 128))
               x)))

         (defun to-ascii (val)
           (if (%<= val 9)
               (%+ val 48)
             (%+ val 55)))

         (defun print-hex-digit (pos val)
           (set-byte base_vga (p-shiftl pos 2) (to-ascii val)))

         (defun print-hex-byte (pos val)
           (print-hex-digit (%+ pos 1) (addr-and val 15))
           (print-hex-digit pos (addr-and (tag-and (p-shiftr val 4) 0) 15)))


         (defun print-hex (pos val)
           (let ((v val))
             (print-hex-byte (%+ pos 6) (addr-and (p-shiftl val 2) 255))
             (print-hex-byte (%+ pos 4) (addr-and (setq v (tag-and (p-shiftr v 6) 0)) 255))
             (print-hex-byte (%+ pos 2) (addr-and (setq v (tag-and (p-shiftr v 8) 0)) 255))
             (print-hex-byte pos (addr-and (tag-and (p-shiftr v 8) 0) 255))))

    
         (set-word (p-constr 0 16) 0 (%symbol-function 'irq))

         (setq base_vga (p-constr (mul (mul 15 16) 256) 0))
         (setq base_sram (p-constr (mul (mul 13 16) 256) 0))
         (setq base_ctrl (p-constr (mul (mul 14 16) 256) 0))

;         (%print (tag-and (p-shiftr base_sram 14) 0))
;         (%print (tag-and (p-shiftr (p-shiftl base_sram 16) 14) 0))


         (defun move-bytes (a y b x n)
           (do ((i 0 (%+ i 4)))
               ((%>= i n))
             (set-byte b (%+ i x) (get-byte a (%+ i y)))))

         (defun compare-bytes (a y b x n)
           (do ((i 0 (%+ i 4))
                (d 0 d))
               ((%>= i n) d)
             (setq d (%+ d (if (%= (get-byte a (%+ i y)) (get-byte b (%+ i x))) 0 1)))))

         (defun fill-bytes (a x c n)
           (do ((i 0 (%+ i 4)))
               ((%>= i n))
             (set-byte a (%+ i x) (%+ c (p-shiftr i 2)))))

         (do ((x 0 (if (%>= x 21280) 0 (%+ x 532)))
              (dd 0 dd)
              (q 33 (if (%>= q 81) 33 (%+ q 1))))
             ((%>= x 32000))
           (fill-bytes base_sram x q 108)
           (move-bytes base_sram x base_vga x 108)
           (move-bytes base_sram x base_sram (%+ x 8192) 108)
           (move-bytes base_sram x base_vga (%+ x 176) 108)
           (move-bytes base_vga x base_vga (%+ x 312) 108)
           (setq dd (%+ dd (compare-bytes base_sram x base_sram (%+ x 8192) 108)))
           (print-hex 5985 dd))))


;; serial terminal with loopback
;; old VGA

(setf *test-a7*
      
      '(let ()
       
         (defun not (x)
           (if x nil -1))

         (defun next-i (i m)
           (addr-and (%+ i 1) m))

         (defun mod-m (i m)
           (if (%>= i m)
               (%- i m)
             i))


         (defun p-shiftl (x i)
           (do ((j 0 (%+ j 1)))
               ((%>= j i) x)
             (setq x (p-shiftl-1 x))))

         (defun p-shiftr (x i)
           (do ((j 0 (%+ j 1)))
               ((%>= j i) x)
             (setq x (p-shiftr-1 x))))

         (defun irq (x)
           (let ((ch (get-word (p-constr 57344 0) 16)) ; read serial char
                 (getpt (get-word 100 0))
                 (insrtpt (get-word 100 4)))
;             (%print ch)
;             (%print insrtpt)
             (set-word 110 insrtpt ch)
;             (%print -1)
;             (%print (get-word 110 insrtpt))
             (let ((insrtpt1 (next-i insrtpt 15)))
               (if (not (%= insrtpt1 getpt))
                   (set-word 100 4 insrtpt1)))
;             (%print (get-word 100 4))
             (let ((s (get-status)))
               (set-status (addr-ior s 128))
;               (%print (get-status))
               x)))

         (defun getch ()
           (let ((getpt (get-word 100 0))
                 (insrtpt (get-word 100 4)))
             (if (%= getpt insrtpt)
                 -1
               (let ((ch (get-word 110 getpt)))
                 (set-word 100 0 (next-i getpt 15))
                 ch))))


         (defun to-ascii (val)
           (if (%<= val 9)
               (%+ val 48)
             (%+ val 55)))

         (defun print-hex-digit (pos val)
           (set-byte base_vga pos (to-ascii val)))

         (defun print-hex-byte (pos val)
           (print-hex-digit (%+ pos 1) (addr-and val 15))
           (print-hex-digit pos (addr-and (tag-and (p-shiftr val 4) 0) 15)))


         (defun print-hex (pos val)
           (let ((v val))
             (print-hex-byte (%+ pos 6) (addr-and (p-shiftl val 2) 255))
             (print-hex-byte (%+ pos 4) (addr-and (setq v (tag-and (p-shiftr v 6) 0)) 255))
             (print-hex-byte (%+ pos 2) (addr-and (setq v (tag-and (p-shiftr v 8) 0)) 255))
             (print-hex-byte pos (addr-and (tag-and (p-shiftr v 8) 0) 255))))

         (set-word (p-constr 0 16) 0 (%symbol-function 'irq))


         (setq base_vga (p-constr 61440 0))
         (setq base_sram (p-constr 53248 0))
         (setq base_ctrl (p-constr 57344 0))

         (%print (tag-and (p-shiftr base_sram 14) 0))
         (%print (tag-and (p-shiftr (p-shiftl base_sram 16) 14) 0))

         (setq base_low (p-constr 0 0))

         (set-word 100 0 0) ; getpt
         (set-word 100 4 0) ; insrtpt

         (let ((q 0))
           (defun print-char (c)
             (set-byte base_vga q c)
             (setq q (if (%>= q 5453) 0 (%+ q 1)))))


         (do ((out-pos 0 out-pos)
              (i 0 (%+ i 1)))
             (nil)
           (let ((ch (getch)))
             (print-hex 5320 i)
             (if (not (%= ch -1))
                 (progn
                   (setq ch (addr-and (p-shiftl-1 (p-shiftl-1 ch)) 255))
                   (print-char ch)
                  ;(print-hex out-pos ch)
                   (set-byte base_ctrl 20 ch)
                   (set-word base_ctrl 12 (p-constr 0 1798))
                   (setq out-pos (mod-m (%+ out-pos 19) 5320))))))))




;; printing a partly marked line and scrolling up on keypress
;; version for new VGA

(setf *test-a8*
      
      '(let ()
       
         (defun p-shiftl (x i)
           (do ((j 0 (%+ j 1)))
               ((%>= j i) x)
             (setq x (p-shiftl-1 x))))

         (defun p-shiftr (x i)
           (do ((j 0 (%+ j 1)))
               ((%>= j i) x)
             (setq x (p-shiftr-1 x))))

  
         (defun mul (a b)
           (let ((acc 0)
                 (i 32))
             (do-until ((%= i 0) acc)
                       (if (%= (tag-and (addr-and b 1) 0) 1)
                           (setq acc (%+ acc a)))
                       (setq b (p-shiftr-1 b))
                       (setq a (p-shiftl-1 a))
                       (setq i (%- i 1)))))

         (defun irq (x)
           (progn
             (get-word (p-constr 57344 0) 8)
             (print-hex 5320 250)
             (setq *do-scroll* 1)
             (let ((s (get-status)))
               (set-status (addr-ior s 128))
               x)))

         (defun to-ascii (val)
           (if (%<= val 9)
               (%+ val 48)
             (%+ val 55)))

         (defun print-hex-digit (pos val)
           (set-byte base_vga (p-shiftl pos 2) (to-ascii val)))

         (defun print-hex-byte (pos val)
           (print-hex-digit (%+ pos 1) (addr-and val 15))
           (print-hex-digit pos (addr-and (tag-and (p-shiftr val 4) 0) 15)))


         (defun print-hex (pos val)
           (let ((v val))
             (print-hex-byte (%+ pos 6) (addr-and (p-shiftl val 2) 255))
             (print-hex-byte (%+ pos 4) (addr-and (setq v (tag-and (p-shiftr v 6) 0)) 255))
             (print-hex-byte (%+ pos 2) (addr-and (setq v (tag-and (p-shiftr v 8) 0)) 255))
             (print-hex-byte pos (addr-and (tag-and (p-shiftr v 8) 0) 255))))

    
         (set-word (p-constr 0 16) 0 (%symbol-function 'irq))

         (setq base_vga (p-constr (mul (mul 15 16) 256) 0))
         (setq base_sram (p-constr (mul (mul 13 16) 256) 0))
         (setq base_ctrl (p-constr (mul (mul 14 16) 256) 0))

         (defun scroll ()
           (do ((i 0 (%+ i 4)))
               ((%>= i 21280))
             (set-word base_vga i (get-word base_vga (%+ i 532)))))

         (do ((i 0 (%+ i 4)))
             ((%>= i 200))
           (set-byte base_vga (%+ i 2660) (%+ (p-shiftr i 2) 32))
           (set-byte base_vga (%+ i 2661) (if (and (%>= i 24) (%<= i 88)) 0 1)))

         (do ((x 0 0))
             (nil)
           (progn
             (if *do-scroll*
                 (progn
                   (scroll)
                   (setq *do-scroll* nil)))))))