;;-*-Lisp-*-
(in-package goal)

;; name: capture.gc
;; name in dgo: capture
;; dgos: GAME, ENGINE

;; Functions for taking a screenshot of VRAM.
;; These are debug-only and leak memory.

;; vif/gif tags to do a transfer of data from VRAM to EE memory.
(deftype gs-store-image-packet (structure)
  ((vifcode        vif-tag      4 :offset-assert 0)
   (giftag         gif-tag        :offset-assert 16)
   (bitbltbuf      gs-bitbltbuf   :offset-assert 32)
   (bitbltbuf-addr gs-reg64       :offset-assert 40)
   (trxpos         gs-trxpos      :offset-assert 48)
   (trxpos-addr    gs-reg64       :offset-assert 56)
   (trxreg         gs-trxreg      :offset-assert 64)
   (trxreg-addr    gs-reg64       :offset-assert 72)
   (finish         int64          :offset-assert 80)
   (finish-addr    gs-reg64       :offset-assert 88)
   (trxdir         gs-trxdir      :offset-assert 96)
   (trxdir-addr    gs-reg64       :offset-assert 104)
   )
  :method-count-assert 9
  :size-assert         #x70
  :flag-assert         #x900000070
  )

(defun gs-set-default-store-image ((packet gs-store-image-packet) (src-fbp int) (src-w int) (src-psm int) (ssax int) (ssay int) (rrw int) (rrh int))
  "Set up a gs-store-image-packet for storing"
  ;; nop
  (set! (-> packet vifcode 0) (new 'static 'vif-tag :cmd (vif-cmd nop)))
  ;; set mskpath3
  (set! (-> packet vifcode 1)
        (new 'static 'vif-tag :imm #x8000 :cmd (vif-cmd mskpath3))
        )
  ;; flush!
  (set! (-> packet vifcode 2)
        (new 'static 'vif-tag :cmd (vif-cmd flusha) :msk #x1)
        )
  ;; direct gif transfer.
  (set! (-> packet vifcode 3)
        (new 'static 'vif-tag :imm #x6 :cmd (vif-cmd direct) :msk #x1)
        )
  ;;gif a+d
  (set! (-> packet giftag) (the-as gif-tag
                                   (make-u128
                                    (new 'static 'gif-tag-regs :regs0 (gif-reg-id a+d))
                                    (new 'static 'gif-tag64 :nloop #x5 :eop #x1 :nreg #x1)
                                    )
                                   )
        )

  ;; all the a+d
  (set! (-> packet bitbltbuf) (new 'static 'gs-bitbltbuf :sbp src-fbp :sbw src-w :spsm src-psm))
  (set! (-> packet bitbltbuf-addr) (gs-reg64 bitbltbuf))
  (set! (-> packet trxpos) (new 'static 'gs-trxpos :ssax ssax :ssay ssay))
  (set! (-> packet trxpos-addr) (gs-reg64 trxpos))
  (set! (-> packet trxreg) (new 'static 'gs-trxreg :rrw rrw :rrh rrh))
  (set! (-> packet trxreg-addr) (gs-reg64 trxreg))
  (set! (-> packet finish) 0)
  (set! (-> packet finish-addr) (gs-reg64 finish))
  (set! (-> packet trxdir) (new 'static 'gs-trxdir :xdir #x1))
  (set! (-> packet trxdir-addr) (gs-reg64 trxdir))
  (.sync.l)
  7
  )


(defun store-image ((oddeven int))
  "Store an image to image.raw"
  (local-vars (ptr-1 (pointer uint8)) (y-idx int) (y-idx-2 int))
  (let ((width 512)
        (height (-> *video-parms* screen-sy))
        (file (new 'debug 'file-stream "image.raw" 'write))
        )
    ;; create (and leak memory) for 2 arrays.
    (let ((buff0 (new 'debug 'boxed-array uint128 (sar (* width height) 2))))
      (let ((buff1 (new 'debug 'boxed-array uint128 (sar (* width height) 2))))
        ;; set up a packet.
        (let ((packet (new 'static 'gs-store-image-packet)))
          ;; capture one field
          (gs-set-default-store-image packet #x2800 (sar width 6) 0 0 0 width height)
          (flush-cache 0)
          (gs-store-image packet (-> buff0 data))
          (sync-path 0 0)
          ;; capture other field
          (gs-set-default-store-image packet #x3000 (sar width 6) 0 0 0 width height)
          (flush-cache 0)
          (gs-store-image packet (-> buff1 data))
          )
        ;; wait for capture to complete.
        (sync-path 0 0)
        (let ((ptr-0 (-> buff0 data)))
          (set! ptr-1 (-> buff1 data))
          (cond
            ((zero? oddeven)
             (set! y-idx 0)
             (while (< y-idx height)
               (file-stream-write file (&+ ptr-0 (* y-idx (shl width 2))) (the-as uint (shl width 2)))
               (file-stream-write file (&+ ptr-1 (* y-idx (shl width 2))) (the-as uint (shl width 2)))
               (set! y-idx (+ y-idx 1))
               )
             )
            (else
             (set! y-idx-2 0)
             (while (< y-idx-2 height)
               (file-stream-write file (&+ ptr-1 (* y-idx-2 (shl width 2))) (the-as uint (shl width 2)))
               (file-stream-write file (&+ ptr-0 (* y-idx-2 (shl width 2))) (the-as uint (shl width 2)))
               (set! y-idx-2 (+ y-idx-2 1))
               )
             )
            )
          )
        (format #t "oddeven = ~d~%" oddeven)
        ;; this does nothing.
        (delete buff1)
        )
      ;; also does nothing.
      (delete buff0)
      )
    (file-stream-close file)
    )
  0
  )