;;; -*- Mode:LISP; Package:(NTV :use (PRIMS)); Readtable:CL; Base:10 -*- ;;; Init values are test hacks for use without calling select-sheet: (define-global-frame tv) (define-global-variable tv *tv-screen-locations-per-line* 32.) (define-global-variable tv *tv-screen-width* 1024. "Not used??") (define-global-variable tv *tv-screen-buffer-address* 0.) (define-global-variable tv *tv-screen-buffer-end-address* #.user:(/ (length *screen-array*) 2)) ;temporary value (define-global-variable tv *tv-screen-buffer-log2-bits-per-pixel* 0.) (define-global-variable tv *tv-screen-buffer-bit-offset* 0.) ;;; Real, non-test defvars: ;(defvar *tvxyadr-word* nil) ;(defvar *tvxyadr-bit* nil) (defun select-sheet (sheet-or-array) (if (typep sheet-or-array 'sheet) ; This isn't a type! (progn (if (eq sheet-or-array *tv-current-sheet*) (return-from select-sheet nil)) (if (not (eq sheet-or-array *currently-prepared-sheet*)) (error "Sheet, ~a, not prepared." sheet-or-array)) (setq *tv-screen-locations-per-line* (sheet-locations-per-line sheet-or-array)) (setq *tv-screen-width* (sheet-width sheet-or-array)) (let ((array (sheet-array sheet-or-array))) (setq *tv-screen-buffer-address* (array-origin array)) (setq *tv-screen-buffer-end-address* (+ *tv-screen-buffer-address* (array-n-words array))) (setq *tv-screen-buffer-log2-bits-per-pixel* (array-log2-bits-per-elt array)) (setq *tv-screen-buffer-bit-offset* (array-bit-offset array)) ) ) (if (typep sheet-or-array 'array) (progn (if (eq sheet-or-array *tv-current-sheet*) (return-from select-sheet nil)) (setq *tv-screen-locations-per-line* (array-smallest-clump-n-words sheet-or-array)) (setq *tv-screen-width* (array-smallest-clump-n-bits sheet-or-array)) (setq *tv-screen-buffer-log2-bits-per-pixel* (array-log2-bits-per-elt sheet-or-array)) (setq *tv-screen-buffer-address* (array-origin sheet-or-array)) (setq *tv-screen-buffer-end-address* (+ *tv-screen-buffer-address* (array-n-words sheet-or-array))) (setq *tv-screen-buffer-bit-offset* (array-bit-offset sheet-or-array)) ) (error "Argument, ~a, is not a sheet or array." sheet-or-array))) (setq *tv-current-sheet* sheet-or-array) ) (defun boole (op arg1 arg2) (lisp:boole op arg1 arg2)) (defmacro tvxyadr (pixel-x pixel-y) `(let ((var (+ *tv-screen-buffer-bit-offset* (hw:dpb ,pixel-x (byte (- 32 *tv-screen-buffer-log2-bits-per-pixel*) *tv-screen-buffer-log2-bits-per-pixel*) 0)))) (values (+ (* ,pixel-y ;word *tv-screen-locations-per-line*) (hw:ldb var (byte 27 5) 0)) (hw:ldb var (byte 5 0) 0)))) ;bit (defun draw-rectangle (width height x y alu sheet) (if (or (zerop height) (zerop width)) (return-from draw-rectangle nil)) ; (select-sheet sheet) *****test (multiple-value-bind (tvxyadr-word tvxyadr-bit) (tvxyadr x y) (if (< tvxyadr-word *tv-screen-buffer-address*) (error "Would address below legal range.")) (if (> (+ tvxyadr-word (* height *tv-screen-locations-per-line*)) *tv-screen-buffer-end-address*) (error "Would address above legal range.")) (let* ((fudged-bitswidth (+ (hw:32ash width *tv-screen-buffer-log2-bits-per-pixel*) tvxyadr-bit)) (fudged-wordswidth (hw:ldb fudged-bitswidth (byte 27 5) 0)) (mask (hw:selective-deposit #xffffffff (byte (- 32 tvxyadr-bit) tvxyadr-bit) 0))) (do ((col-base tvxyadr-word (1+ col-base)) (words fudged-wordswidth (1- words))) ((minusp words)) (if (zerop words) (let ((tailbits (hw:ldb fudged-bitswidth (byte 5 0) 0))) (if (zerop tailbits) (return-from draw-rectangle nil)) (setq mask (hw:ldb mask (byte tailbits 0) 0)))) (let ((quick (and (= mask #xffffffff) (or (and (= alu tv:alu-ior) #xffffffff) (and (= alu tv:alu-andca) 0))))) (if quick (progn (hw:write-md-unboxed quick) (do ((addr col-base (+ addr *tv-screen-locations-per-line*)) (lines height (1- lines))) ((zerop lines)) (hw:vma-start-write-unboxed addr))) (do ((addr col-base (+ addr *tv-screen-locations-per-line*)) (lines height (1- lines))) ((zerop lines)) (hw:vma-start-read-vma-unboxed-md-unboxed addr) (hw:md-start-write-unboxed (boole alu (hw:read-md) mask))))) (setq mask #xffffffff))))) (defmacro with-font-char-etc (charcode &body body) `(let* ((font-word-addr (+ (* ,charcode *font-words-per-char*) *font-origin*)) (font-rows-per-word *font-rows-per-word*) (font-word-rows-remaining font-rows-per-word) (font-raster-shift *font-raster-shift*) (tv-screen-locations-per-line *tv-screen-locations-per-line*) font-word) (xx-write-vma-start-read font-word-addr) (setq font-word (xx-read-md)) ,@body)) (defmacro font-char-setup-next-row () `(setq font-word (if (zerop (setq font-word-rows-remaining (1- font-word-rows-remaining))) (progn (xx-write-vma-start-read (setq font-word-rows-remaining font-rows-per-word font-word-addr (1+ font-word-addr))) (xx-read-md)) (ldb (byte 32. font-raster-shift) font-word)))) (defun %draw-char (font charcode alu x y sheet) ;(select-sheet sheet) *****test (multiple-value-bind (tvxyadr-word tvxyadr-bit) (tvxyadr x y) (if (not (eq font *font*)) (if (> (font-raster-width font) 32.) (error "Font, ~a, wider than 32 bits." font) (setq *font* font *font-origin* (array-origin font) *font-raster-height* (font-raster-height font) *font-raster-width* (font-raster-width font) *font-raster-shift* (- 32. (font-raster-width font)) *font-rows-per-word* (font-rows-per-word font) *font-words-per-char* (font-words-per-char font)))) (if (< tvxyadr-word *tv-screen-buffer-address*) (error "Would address sheet below legal range.")) (with-font-char-etc charcode (if (> (+ *font-raster-width* ;crosses word boundary? tvxyadr-bit) 32.) (if (> (+ tvxyadr-word (* *font-raster-height* tv-screen-locations-per-line) 1) ;Because it crosses word boundary. *tv-screen-buffer-end-address*) (error "Would address sheet above legal range.") (let ((left-bytespec (byte (- 32. tvxyadr-bit) tvxyadr-bit)) (right-bytespec (byte (- (+ tvxyadr-bit *font-raster-width*) 32.) (- tvxyadr-bit 32.)))) (do ((word tvxyadr-word (+ word tv-screen-locations-per-line)) (lines *font-raster-height* (1- lines))) ((zerop lines)) (xx-write-vma-start-read word) (xx-write-md-start-write (logior (xx-read-md) (dpb font-word left-bytespec 0))) (xx-write-vma-start-read (1+ word)) (xx-write-md-start-write (logior (xx-read-md) (dpb font-word right-bytespec 0))) (font-char-setup-next-row)))) ;Else clause -- no cross of word boundary. (if (> (+ tvxyadr-word (* *font-raster-height* tv-screen-locations-per-line)) *tv-screen-buffer-end-address*) (error "Would address sheet above legal range.") (let ((bytespec (byte *font-raster-width* tvxyadr-bit))) (do ((word tvxyadr-word (+ word tv-screen-locations-per-line)) (lines *font-raster-height* (1- lines))) ((zerop lines)) (xx-write-vma-start-read word) (xx-write-md-start-write (logior (xx-read-md) (dpb font-word bytespec 0))) (font-char-setup-next-row))))))))