honeylisp/neuttower/gfx.fnl

(local {: lo : hi} (require :lib.util))
(local {: vm : mapw : maph : org} (require :neuttower.defs))

; Graphics routines
(vm:def :mixed [:sta :0xc053])
(vm:def :textmode [:sta :0xc051])
(vm:def :page1 [:sta :0xc054])
(vm:def :page2 [:sta :0xc055])

; starting address:
; 0x2000 + (x*2) + (y%4 * 0x100) + ((y/4) * 0x28)
; x between 0-19
; y between 0-12
; yx - 16-bit value, low byte x, high byte y
(vm.code:append :screeny-lookup [:bytes "\0\040\080"])
(vm:def :yx>screen ; yx -- p
  [:lda vm.TOPH :x]         ; a=y
  [:lsr :a] [:lsr :a]       ; a=y/4
  [:tay]                    ; y=y/4
  [:lda 0x03]
  [:and vm.TOPH :x]         ; a=y%4
  [:ora 0x20]               ; a=0x20 + y%4
  [:sta vm.TOPH :x]         ; high byte is set (and y is wiped)
  [:lda vm.TOP :x]          ; a=x
  [:asl :a]                 ; a = x*2
  [:clc]
  [:adc :screeny-lookup :y] ; a=x*2 + (y/4)*0x28
  [:sta vm.TOP :x]          ; low byte is set
)

; note: the graphical tile data must not cross a page boundary
; (this happens automatically because each tile is 32 bytes and we
; start them on a page; this lets lookup-tile be fast)
(fn draw-block []
  [:block
    [:clc]
    [:ldy 8]
  :loop
    [:lda [vm.TOP :x]]
    [:sta [vm.ST1 :x]]
    [:inc vm.TOP :x]
    [:lda vm.ST1H :x]
    [:adc 4]
    [:sta vm.ST1H :x]
    [:dey]
    [:bne :loop]])

(fn draw-vertical-block []
  [:block
    (draw-block)
    [:lda vm.ST1H :x]
    [:sbc 31] ; with carry clear this is 32
    [:sta vm.ST1H :x]
    [:lda vm.ST1 :x]
    [:ora 0x80]
    [:sta vm.ST1 :x]
    (draw-block)])

(vm:def :drawtile ; p gfx --
  (draw-vertical-block)
  [:lda vm.ST1H :x]
  [:sbc 31]
  [:sta vm.ST1H :x]
  [:lda vm.ST1 :x]
  [:sbc 0x7f]
  [:sta vm.ST1 :x]
  (draw-vertical-block)
  (vm:drop) (vm:drop))

(vm:def :clearline ; pscreen --
  [:lda vm.TOP :x] [:sta vm.W]
  [:lda vm.TOPH :x] [:sta vm.WH]
  (vm:drop)
  [:block
    :row
      [:ldy 0x27] [:lda 0]
    :start
      [:sta [vm.W] :y]
      [:dey]
      [:bpl :start]

      [:lda vm.WH]
      [:cmp 0x3c]
      [:bcs :done]
      ; cmp has cleared carry for us here
      [:lda 4] [:adc vm.WH] [:sta vm.WH]
      [:bcc :row]
    :done])

(vm:word :drawfooter
  0x39d0 :clearline
  0x2250 :clearline 0x22d0 :clearline 0x2350 :clearline 0x23d0 :clearline)

(vm:word :drawmaprow ; pscreen pmap -- pmap
  mapw (vm:for
    :2dup :bget :lookup-tile :drawtile
    :inc :swap :inc :inc :swap) :swap :drop)

(vm:word :drawmap
  :map 0x0c00 (vm:until 0x100 :-
    :dup :yx>screen ; pmap yx pscreen
    :<rot :drawmaprow :swap ; pmap yx
  :dup :not) :drop :drop)

(vm:word :clearfooter
  :map 0x0300 (vm:until 0x100 :-
    :dup 0x0900 :+ :yx>screen
    :<rot :drawmaprow :swap
  :dup :not) :drop :drop :player-redraw)

(vm.code:append :tilepage [:db #(hi ($1:lookup-addr :jaye-tileset))])
(vm:def :lookup-tile ; itile -- ptile
  ; each tile is 32 bytes; 2^5
  ; we save some cycles by storing the indices as lllhhhhh, so we don't need to shift them'
  [:lda vm.TOP :x] [:tay]
  [:and 0x1f]
  [:clc] [:adc :tilepage]
  [:sta vm.TOPH :x]
  [:tya] [:and 0xe0]
  [:sta vm.TOP :x])
(vm:def :set-human-tileset
  [:lda #(hi ($1:lookup-addr :jaye-tileset))]
  [:sta :tilepage])
(vm:def :set-prog-tileset
  [:lda #(hi ($1:lookup-addr :neut-tileset))]
  [:sta :tilepage])

(vm:word :draw-portrait ; pgfx
  0x2252 :over :drawtile
  0x2352 :over 32 :+ :drawtile
  0x2254 :over 64 :+ :drawtile
  0x2354 :swap 96 :+ :drawtile)