honeylisp/game/init.fnl

(local lume (require :lib.lume))
(local asm (require :asm.asm))
(local VM (require :asm.vm))
(local tile (require :game.tiles))
(local link (require :link))
(local {: lo : hi} (require :lib.util))
(local {: walkable} tile.flag-to-bit)
(local prg (asm.new))

(local tiles (prg:org 0x4100))
(local vm (VM.new prg))
(local code1 vm.code)
(local mapw 20)
(local maph 12)

(local mon {
  :hexout :0xfdda
  :putchar :0xfded
  :bell :0xff3a
})

(fn achar [c] (bit.bor (string.byte c) 0x80))
(fn astr [s]
  (-> [(string.byte s 1 -1)]
    (lume.map #(bit.bor $1 0x80))
    (-> (table.unpack) (string.char))))

; a handful of debugging words
(vm:def :.
  [:lda vm.TOPH :x]
  [:jsr mon.hexout]
  [:lda vm.TOP :x]
  [:jsr mon.hexout]
  [:lda (achar " ")]
  [:jsr mon.putchar]
  (vm:drop))

(vm:def :stacklen
  (vm:reserve)
  [:txa] [:lsr :a] [:sta vm.TOP :x]
  [:lda 0] [:sta vm.TOPH :x])

(vm:word :.s
  :stacklen (prg:parse-addr vm.TOP) :swap
  (vm:for :dup :get :. :inc :inc) :drop)

; Graphics routines
(vm:def :hires
  [:sta :0xc050]
  [:sta :0xc057]
  [:sta :0xc052])

(vm:def :mixed [:sta :0xc053])

; 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
(code1: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 :cleargfx
  (vm:push 0x4000)
  [:block :page
    [:dec vm.TOPH :x]
    [:lda 0]
    [:block :start
      [:sta [vm.TOP :x]]
      [:inc vm.TOP :x]
      [:bne :start]]
    [:lda vm.TOPH :x]
    [:cmp 0x20]
    [:bne :page]]
  (vm:drop))

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

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

(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 #(hi tiles.org)]
  [:sta vm.TOPH :x]
  [:tya] [:and 0xe0]
  [:sta vm.TOP :x])

(fn rot8l [n] ; clears carry
  (local block [:block [:clc]])
  (for [_ 1 n] (table.insert block [:block [:asl :a] [:adc 0]]))
  block)

(vm:def :lookup-flags ; itile -- flags
  [:lda vm.TOP :x]
  (rot8l 3) ; lllhhhhh > hhhhhlll
  [:adc #(lo ($1:lookup-addr :tileflags))]
  [:sta vm.W]
  [:lda #(hi ($1:lookup-addr :tileflags))]
  [:adc 0]
  [:sta vm.WH]
  [:ldy 0] [:lda [vm.W] :y]
  [:sta vm.TOP :x])

(vm:def :itile-at ; yx -- itile
  [:lda (- maph 1)]
  [:sec]
  [:sbc vm.TOPH :x]
  [:asl :a] ; x2
  [:asl :a] ; x4
  [:sta vm.TOPH :x]
  [:asl :a] ; x8
  [:asl :a] ; x16
  [:clc] [:adc vm.TOPH :x] ; x20
  [:adc vm.TOP :x]
  [:sta vm.TOP :x]
  [:lda #(hi ($1:lookup-addr :map))]
  [:sta vm.TOPH :x]
  [:lda [vm.TOP :x]]
  [:sta vm.TOP :x]
  [:lda 0]
  [:sta vm.TOPH :x])

(vm:word :drawtile-at ; yx --
  :dup :yx>screen :swap
  :itile-at :lookup-tile
  :drawtile)

(vm:def :last-key ; -- key
  (vm:reserve)
  [:lda :0xc000]
  [:and 0x7f]
  [:sta vm.TOP :x]
  [:lda 0]
  [:sta vm.TOPH :x])

(vm:def :read-key ; -- key|0
  [:block
    (vm:reserve)
    [:lda :0xc000]
    [:bmi :key-pressed]
    [:lda 0]
    [:sta vm.TOP :x]
    [:sta vm.TOPH :x]
    (vm:ret)
  :key-pressed
    [:and 0x7f]
    [:sta vm.TOP :x]
    [:lda 0]
    [:sta vm.TOPH :x]
    [:sta :0xc010]])

(vm:word :movement-dir ; key -- dyx
  (vm:case [(string.byte "I") 0xff00]
           [(string.byte "J") 0x00ff]
           [(string.byte "K") 0x0001]
           [(string.byte "M") 0x0100]
           [:else             0x0000]))

(vm:def :yx+ ; yx yx -- yx
  [:lda vm.TOP :x]
  [:clc] [:adc vm.ST1 :x]
  [:sta vm.ST1 :x]
  [:lda vm.TOPH :x]
  [:clc] [:adc vm.ST1H :x]
  [:sta vm.ST1H :x]
  (vm:drop))

(vm:var :jaye-yx 0x090a)
(vm:var :jaye-dir 0xff00)

(vm:word :jaye-tile ; ptile
  :jaye-dir :get
  (vm:case [0xff00 :lit :jaye-n]
           [0x0100 :lit :jaye-s]
           [0x00ff :lit :jaye-w]
           [:else  :lit :jaye-e]))

(vm:word :draw-jaye-yx ; yx --
  :yx>screen :jaye-tile :drawtile)

(vm:word :handle-key :read-key :move-jaye)
(vm:word :bump-jaye ; dir yx -- yx
  :dup :>rot :yx+ ; yxold yxnew
  :dup :itile-at :lookup-flags ; yxold yxnew flags
  walkable :& (vm:if [:swap :drop] [:drop]))

(vm:word :move-jaye ; key --
  :movement-dir :dup (vm:if [
    :dup :jaye-dir :set ; dir
    :jaye-yx :get       ; dir yx
    :dup :drawtile-at   ; dir yx
    :bump-jaye          ; yx
    :dup :jaye-yx :set  ; yx
    :draw-jaye-yx       ;
  ] [:drop]))

(vm:word :full-redraw :cleargfx :drawmap :jaye-yx :get :draw-jaye-yx)
(tile.appendtiles (tile.loadtiles) tiles)

; thought:
; hotswap-safe debug stub at root of call stack
; but REPL debug stub should be very available as a task

; 20x12 means full map is 240 bytes - we have an extra 16 bytes at the end to mess with?
(tile.appendmaps (prg:org 0x4800))

(code1:append :main
  [:jsr :reset]
  [:jsr :interpret]
  [:vm :hires
    :full-redraw
    (vm:forever
      (vm:hotswap-sync :full-redraw)
      :interactive-eval-checkpoint
      :handle-key
    )
    :quit])

(prg:assemble)