honeylisp/neuttower/defs.fnl

(local util (require :lib.util))
(local {: lo : hi : readjson} util)
(local lume (require :lib.lume))
(local asm (require :asm.asm))
(local VM (require :asm.vm))
(local tiles (require :game.tiles))
(local Prodos (require :asm.prodos))

(local prg (asm.new))
(local vm (VM.new prg {:org 0xc00}))
(Prodos.install-words vm)

(local org {
  :boot vm.code
  :code (prg:org 0x4000)
})

(local mapw 20)
(local maph 12)

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


(local controlstate {
  :jaye 0
  :neut 1
  :rexx 2
  :gord 3
  :libb 4
  :count 5
})

(local style {
  :normal 0x80
  :inverse 0x00
  :flashing 0x40
})
(fn str-with-style [s stylebits]
  (-> [(string.byte s 1 -1)]
      (lume.map #(bit.bor (bit.band $1 0x3f) stylebits))
      (-> (table.unpack) (string.char))))
(fn achar [c] (bit.bor (string.byte c) style.normal))
(fn astr [s ?style] (str-with-style s (or ?style style.normal)))

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

; core graphics words needed for booting
(vm:def :hires
  [:sta :0xc050]
  [:sta :0xc057]
  [:sta :0xc052]
  [:sta :0xc054])

(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))

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

; input words
(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]])

; "random" numbers
; this is used only for cosmetic purposes and short noise generation, so we can get away
; with just including a short table of random digits rather than implementing our own
; pseudorandom number generator
(var randombytes "")
(for [i 0 0x40] (set randombytes (.. randombytes (string.char (math.random 0 255)))))
(vm.code:append :randombytes [:bytes randombytes])
(vm:var :irandom [:db 0])
(vm:word :rnd
  :irandom :bget
  :dup 1 :+ 0x3f :& :irandom :bset
  :lit :randombytes :+ :bget)

; 20x12 means full map is 240 bytes - we have an extra 16 bytes at the end for metadata
(fn append-map [map org label]
  (org:append
    [:align 0x100] label
    [:bytes (map.map:fromhex)]
    [:db (length map.objects)]
    [:dw (tiles.encode-yx map.jaye)]
    [:dw (tiles.encode-yx map.neut)]
    [:dw (if map.gord-following (tiles.encode-yx map.jaye) 0xffff)]
    [:jmp (if (= (or map.tickword "") "") :next map.tickword)]
    [:jmp (if (= (or map.moveword "") "") :move-noop map.moveword)]
    [:jmp (if (= (or map.loadword "") "") :next map.loadword)]))

(vm.code:append :map-ptr [:db 0] :map-page [:db 0])
(vm:word :map :lit :map-ptr :get)
(vm:word :entity-count :map 240 :+ :bget)
(vm:word :map-jaye-yx :map 241 :+ :get)
(vm:word :map-neut-yx :map 243 :+ :get)
(vm:word :map-gord-yx :map 245 :+ :get)
(vm:word :map-specific-tick :map 247 :+ :execute)
(vm:word :map-specific-move :map 250 :+ :execute)
(vm:word :map-specific-load :map 253 :+ :execute)

(fn deflevel [mapfile label]
  (local level prg) ; todo: (asm.new prg) - if we want to load levels as an overlay
  (local org level.vm.code) ; (level:org org.level.org) - if we want to give level data a stable loxation
  (local map (readjson mapfile))
  (local entity (require :neuttower.entity))
  (append-map map org label)
  (entity.append-from-map map org label)
  (set level.vm.code org)
  level)

(fn say-runon [portrait ...]
  (local result [:vm (.. :draw-p portrait)])
  (local lines [...])
  (local ilineOffset (if (< (length lines) 4) 1 0))
  (each [iline line (ipairs lines)]
    (table.insert result [:vm (vm:str line) (.. :draw-text (+ iline ilineOffset))]))
  result)

(fn say [portrait ...]
  (local result (say-runon portrait ...))
  (table.insert result :dismiss-dialog)
  result)

(local tilelist (tiles.loadgfx tiles.fn-tiles))
(fn itile [label] (tiles.find-itile tilelist label))

(set vm.code org.code)

{: vm : prg : mapw : maph : mon : org : achar : astr : style : rot8l : deflevel : say : say-runon : itile : tilelist : controlstate}