anchor.diff:  (defctrl sprite-size          #x20  8  16)
   (defctrl vblank-nmi           #x80 nil t)
   
  +(defmethod update-ctrl ((ppu ppu) val)
  +  (setf (ppu-ctrl ppu) val)
  +  (with-accessors ((meta ppu-meta)) ppu
  +    (setf (getf meta :x) (logior (wrap-byte (getf meta :x)) (x-scroll-offset ppu))
  +          (getf meta :y) (logior (wrap-byte (getf meta :y)) (y-scroll-offset ppu)))))
  +
   (defmacro defmask (name compare)
     "Define PPU mask register methods." ; TODO: elaborate
     `(defmethod ,name ((ppu ppu))
  
positive.code: (defstatus set-sprite-overflow 5)
  (defstatus set-sprite-zero-hit 6)
  (defstatus set-in-vblank       7)
  
  ;;;; Helpers
  
  (defun wrap-nametable (val)
    "Wrap VAL to index into the PPU nametable."
    (logand val #x07ff))
  
  (defun wrap-palette (val)
    "Wrap VAL to index into the PPU palette."
    (logand val #x1f))
  
  ;;;; VRAM Memory Map
  
  (defmethod read-vram ((ppu ppu) addr)
    (cond ((< addr #x2000) (aref (ppu-pattern-table ppu) addr))
          ((< addr #x3f00) (aref (ppu-nametable ppu) (wrap-nametable addr)))
          ((< addr #x4000) (aref (ppu-palette ppu) (wrap-palette addr)))
          (t (error "READ: invalid vram address ~a" addr))))
  
  (defmethod store-vram ((ppu ppu) addr val)
    (cond ((< addr #x2000) (setf (aref (ppu-pattern-table ppu) addr) val))
          ((< addr #x3f00) (let ((wrapped (wrap-nametable addr)))
                             (setf (aref (ppu-nametable ppu) wrapped) val)))
          ((< addr #x4000) (let ((wrapped (wrap-palette addr)))
                             (when (= wrapped #x10) (setf wrapped #x00))
                             (setf (aref (ppu-palette ppu) wrapped) val)))
          (t (error "WRITE: invalid vram address ~a" addr)))
    (incf (ppu-addr ppu) (vram-step ppu)))
  
  ;;;; Sprite RAM/Object Attribute Memory (OAM)
  
  (defmethod read-oam ((ppu ppu) addr)
    (aref (ppu-oam ppu) addr))
  
  (defmethod store-oam ((ppu ppu) val)
    (with-accessors ((addr ppu-oam-addr)) ppu
      (setf (aref (ppu-oam ppu) addr) val)
      (incf addr)))
  
  (declaim (inline make-sprite))
  (defstruct sprite
    (x           0 :type u8)
    (y           0 :type u8)
    (tile-index  0 :type u8)
    (attribute   0 :type u8))
  
  (defmethod palette ((sprite sprite))
    (+ 4 (logand (sprite-attribute sprite) 3)))
  
  (defmethod flip-h ((sprite sprite))
    (not (zerop (logand (sprite-attribute sprite) #x40))))
  
  (defmethod flip-v ((sprite sprite))
    (not (zerop (logand (sprite-attribute sprite) #x80))))
  
  (defmethod priority ((sprite sprite))
    (if (zerop (logand (sprite-attribute sprite) #x20))
        :above
        :below))
  
  (defmethod on-scanline ((sprite sprite) (ppu ppu))
    (with-accessors ((scanline ppu-scanline)) ppu
      (if (< scanline (sprite-y sprite))
          nil
          (ecase (sprite-size ppu)
            (08 (< scanline (+ (sprite-y sprite) 08)))
            (16 (< scanline (+ (sprite-y sprite) 16)))))))
  
  (defmethod in-bounding-box ((sprite sprite) (ppu ppu) x)
    ; KLUDGE: Y is assumed to be the current scanline.
    (and (>= x (sprite-x sprite))
         (< x (+ (sprite-x sprite) 8))
         (on-scanline sprite ppu)))
  
  (defmethod tiles ((sprite sprite) (ppu ppu))
    (let ((base (sprite-pattern-addr ppu)))
      (ecase (sprite-size ppu)
        (8 (logior (sprite-tile-index sprite) base))
        (16 (let* ((initial (sprite-tile-index sprite))
                   (tile (logandc2 initial 1)))
              (unless (zerop (logand initial 1))
                (incf tile #x1000))
              (list tile (1+ tile)))))))
  
  ;;;; Colors
  
  (declaim (inline make-color get-color put-pixel))
  (defstruct color
    (r 0 :type u8)
    (g 0 :type u8)
    (b 0 :type u8))
  
  (defun get-color (index)
    (let* ((base (* index 3))
           (red   (aref *color-palette* (+ 2 base)))
           (green (aref *color-palette* (+ 1 base)))
           (blue  (aref *color-palette* (+ 0 base))))
      (+ (ash red 16) (ash green 8) blue)))
  
  (defun put-pixel (x y color)
    (let ((base (* 3 (+ x (* y +width+)))))
      (setf (aref *frame* (+ base 0)) (color-r color)
            (aref *frame* (+ base 1)) (color-g color)
            (aref *frame* (+ base 2)) (color-b color))))
  
  (defmethod get-pixel-color ((ppu ppu) kind tile x y)
    (let ((offset (+ y (ash tile 4))))
      (case kind
        (:bg (incf offset (bg-pattern-addr ppu)))
        (:sprite (incf offset (sprite-pattern-addr ppu))))
      (let* ((plane-0 (read-vram ppu offset))
             (plane-1 (read-vram ppu (+ offset 8)))
             (bit-0 (logand (ash plane-0 (- (mod x 8) 7)) 1))
             (bit-1 (logand (ash plane-1 (- (mod x 8) 7)) 1)))
        (logior (ash bit-1 1) bit-0))))
  
  ;;;; Main PPU Methods - *UNTESTED*
  
  (defun from-oam (oam index)
    (make-sprite :y          (+ 0 (* 4 (aref oam index)))
                 :tile-index (+ 1 (* 4 (aref oam index)))
                 :attribute  (+ 2 (* 4 (aref oam index)))
                 :x          (+ 3 (* 4 (aref oam index)))))
  
  (defun get-visible-sprites (ppu)
    ; TODO: Did I mistranslate semantics here?
    (with-accessors ((oam ppu-oam)) ppu
      (loop with count = 0 with result = (make-array 8 :initial-element nil)
         for i from 0 to 64 for sprite = (from-oam oam i)
         when (on-scanline sprite ppu)
         do (if (< count 8)
                (setf (aref result count) i
                      count (1+ count))
                (set-sprite-overflow ppu 1))
         finally (return result))))
  
  (defmethod read-status ((ppu ppu))
    (setf (ppu-scroll-next ppu) :x
          (ppu-addr-next ppu) :hi)
    (ppu-status ppu))
  
  (defmethod update-ctrl ((ppu ppu) val)
    (setf (ppu-ctrl ppu) val)
    (with-accessors ((x ppu-scroll-x)
                     (y ppu-scroll-y)) ppu
      (let ((new-x (logior (wrap-byte x) (x-scroll-offset ppu)))
            (new-y (logior (wrap-byte y) (y-scroll-offset ppu))))
        (rotatef x new-x y new-y))))
  
  (defmethod update-scroll ((ppu ppu) val)
    (flet ((magic (old-val) ; TODO: Why? Rename after enlightenment.
  
negative.code: (defmethod update-addr ((ppu ppu) val)
    (with-accessors ((meta ppu-meta)
                     (addr ppu-addr)
                     (next ppu-addr-next)) ppu
      (ecase next
        (:hi (setf addr (logior (logand addr #x00ff) (ash val 8))
                   next :lo))
        (:lo (setf addr (logior (logand addr #xff00) val)
                   next :hi
                   (getf meta :x)
                   ;; HACK: Fake out the X scroll register.
                   ;; TODO: Y scrolling.
                   (let* ((initial (wrap-nametable addr))
                          (base (if (< initial #x400) 0 256)))
                     (logior (wrap-byte (getf meta :x)) base)))))))
  
  ;;;; Helpers
  
  (defun wrap-nametable (val)
    "Wrap VAL to index into the PPU nametable."
    (logand val #x07ff))
  
  (defun wrap-palette (val)
    "Wrap VAL to index into the PPU palette."
    (logand val #x1f))
  
  ;;;; VRAM Memory Map
  
  (defmethod read-vram ((ppu ppu) addr)
    (cond ((< addr #x2000) (aref (ppu-pattern-table ppu) addr))
          ((< addr #x3f00) (aref (ppu-nametable ppu) (wrap-nametable addr)))
          ((< addr #x4000) (aref (ppu-palette ppu) (wrap-palette addr)))
          (t (error "READ: invalid vram address ~a" addr))))
  
  (defmethod store-vram ((ppu ppu) addr val)
    (cond ((< addr #x2000) (setf (aref (ppu-pattern-table ppu) addr) val))
          ((< addr #x3f00) (let ((wrapped (wrap-nametable addr)))
                             (setf (aref (ppu-nametable ppu) wrapped) val)))
          ((< addr #x4000) (let ((wrapped (wrap-palette addr)))
                             (when (= wrapped #x10) (setf wrapped #x00))
                             (setf (aref (ppu-palette ppu) wrapped) val)))
          (t (error "WRITE: invalid vram address ~a" addr)))
    (incf (ppu-addr ppu) (vram-step ppu)))
  
  ;;;; Sprite RAM/Object Attribute Memory (OAM)
  
  (defmethod read-oam ((ppu ppu) addr)
    (aref (ppu-oam ppu) addr))
  
  (defmethod store-oam ((ppu ppu) val)
    (with-accessors ((addr ppu-oam-addr)) ppu
      (setf (aref (ppu-oam ppu) addr) val)
      (incf addr)))
  
  (declaim (inline make-sprite))
  (defstruct sprite
    (x           0 :type u8)
    (y           0 :type u8)
    (tile-index  0 :type u8)
    (attribute   0 :type u8))
  
  (defmethod palette ((sprite sprite))
    (+ 4 (logand (sprite-attribute sprite) 3)))
  
  (defmethod flip-h ((sprite sprite))
    (not (zerop (logand (sprite-attribute sprite) #x40))))
  
  (defmethod flip-v ((sprite sprite))
    (not (zerop (logand (sprite-attribute sprite) #x80))))
  
  (defmethod priority ((sprite sprite))
    (if (zerop (logand (sprite-attribute sprite) #x20))
        :above
        :below))
  
  (defmethod on-scanline ((sprite sprite) (ppu ppu))
    (with-accessors ((scanline ppu-scanline)) ppu
      (if (< scanline (sprite-y sprite))
          nil
          (ecase (sprite-size ppu)
            (08 (< scanline (+ (sprite-y sprite) 08)))
            (16 (< scanline (+ (sprite-y sprite) 16)))))))
  
  (defmethod in-bounding-box ((sprite sprite) (ppu ppu) x)
    ; KLUDGE: Y is assumed to be the current scanline.
    (and (>= x (sprite-x sprite))
         (< x (+ (sprite-x sprite) 8))
         (on-scanline sprite ppu)))
  
  (defmethod tiles ((sprite sprite) (ppu ppu))
    (let ((base (sprite-pattern-addr ppu)))
      (ecase (sprite-size ppu)
        (8 (logior (sprite-tile-index sprite) base))
        (16 (let* ((initial (sprite-tile-index sprite))
                   (tile (logandc2 initial 1)))
              (unless (zerop (logand initial 1))
                (incf tile #x1000))
              (list tile (1+ tile)))))))
  
  ;;;; Colors
  
  (declaim (inline make-color get-color put-pixel))
  (defstruct color
    (r 0 :type u8)
    (g 0 :type u8)
    (b 0 :type u8))
  
  (defun get-color (index)
    (let* ((base (* index 3))
           (red   (aref *color-palette* (+ 2 base)))
           (green (aref *color-palette* (+ 1 base)))
           (blue  (aref *color-palette* (+ 0 base))))
      (+ (ash red 16) (ash green 8) blue)))
  
  (defun put-pixel (x y color)
    (let ((base (* 3 (+ x (* y +width+)))))
      (setf (aref *frame* (+ base 0)) (color-r color)
            (aref *frame* (+ base 1)) (color-g color)
            (aref *frame* (+ base 2)) (color-b color))))
  
  (defmethod get-pixel-color ((ppu ppu) kind tile x y)
    (let ((offset (+ y (ash tile 4))))
      (case kind
        (:bg (incf offset (bg-pattern-addr ppu)))
        (:sprite (incf offset (sprite-pattern-addr ppu))))
      (let* ((plane-0 (read-vram ppu offset))
             (plane-1 (read-vram ppu (+ offset 8)))
             (bit-0 (logand (ash plane-0 (- (mod x 8) 7)) 1))
             (bit-1 (logand (ash plane-1 (- (mod x 8) 7)) 1)))
        (logior (ash bit-1 1) bit-0))))
  
  ;;;; Main PPU Methods - *UNTESTED*
  
  (defun from-oam (oam index)
    (make-sprite :y          (+ 0 (* 4 (aref oam index)))
                 :tile-index (+ 1 (* 4 (aref oam index)))
                 :attribute  (+ 2 (* 4 (aref oam index)))
                 :x          (+ 3 (* 4 (aref oam index)))))
  
  (defun get-visible-sprites (ppu)
    ; TODO: Did I mistranslate semantics here?
    (with-accessors ((oam ppu-oam)) ppu
      (loop with count = 0 with result = (make-array 8 :initial-element nil)
         for i from 0 to 64 for sprite = (from-oam oam i)
         when (on-scanline sprite ppu)
         do (if (< count 8)
                (setf (aref result count) i
                      count (1+ count))
                (set-sprite-overflow ppu 1))
         finally (return result))))
  
  (defmethod read-status ((ppu ppu))
    (setf (ppu-scroll-next ppu) :x
          (ppu-addr-next ppu) :hi)
    (ppu-status ppu))
  
  (defun buffered-read (ppu)
    (let* ((addr (ppu-addr ppu))
  