honeylisp/game/init.fnl

(local util (require :lib.util))
(local {: lo : hi : readjson} util)
(local lume (require :lib.lume))
(local {: prg : vm : org : mapw : maph} (require :game.defs))

(local tile (util.reload :game.tiles))
(util.reload :game.gfx)
(util.reload :game.map)
(util.reload :game.entity)

(local {: walkable} tile.flag-to-bit)

(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+ ; yxnew
  :dup :touch-entity :not
  (vm:if
    [:dup :itile-at :lookup-flags ; yxnew flags
     walkable :& (vm:if [:move-player-to] [:drop])]
    [:drop]))

(vm:word :move-player-to ; yx --
  :jaye-yx :get :drawtile-at
  :dup :jaye-yx :set
  :yx>screen :jaye-tile :drawtile)

(vm:word :move-player ; --
  :jaye-dir :get :jaye-yx :get :yx+ :move-player-to)

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

(vm:word :full-redraw :drawmap :object-redraw)
(vm:word :object-redraw :jaye-yx :get :draw-jaye-yx)

(vm:def :draw-pchar ; pscreen pchar --
  [:block
    [:ldy 7] [:clc]
  :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]
  ]
  (vm:drop) (vm:drop))

(vm:def :lookup-pchar ; c -- pchar
  [:sec]
  [:lda vm.TOP :x]
  [:sbc 0x20]
  [:sta vm.TOP :x]
  [:lda 0]
  [:asl vm.TOP :x] [:rol :a] ;x2
  [:asl vm.TOP :x] [:rol :a] ;x4
  [:asl vm.TOP :x] [:rol :a] ;x8
  [:adc #(hi org.font.org)]
  [:sta vm.TOPH :x])

(vm:word :draw-char ; pscreen c --
  :lookup-pchar :draw-pchar)

(vm:word :snooze (vm:for))
(vm:word :textsnooze 0x40 :snooze)
(vm:word :draw-text1 0x2257 :draw-text)
(vm:word :draw-text2 0x22d7 :draw-text)
(vm:word :draw-text3 0x2357 :draw-text)
(vm:word :draw-text4 0x23d7 :draw-text)
(vm:word :draw-text ; st pscreen --
  (vm:while [:over :bget :dup] ; st pscreen c
    :over :swap :draw-char ; st pscreen
    :textsnooze
    :inc :swap :inc :swap)
  :drop :drop :drop)
(vm:word :cleartext
  0x2257 :clearline 0x22d7 :clearline 0x2357 :clearline 0x23d7 :clearline)

(vm:word :wait-for-return (vm:until :read-key (string.byte "\r") :=))
(vm:word :dismiss-dialog :wait-for-return :cleartext)

(tile.appendtiles org.tiles)
(tile.appendgfx org.font (tile.loadgfx tile.fn-font))

; 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?

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

(util.reload :game.level1)

(prg:assemble)