396 lines
9.3 KiB
Fennel
396 lines
9.3 KiB
Fennel
(local lume (require :lib.lume))
|
|
(local asm (require :asm.asm))
|
|
(local VM (require :asm.vm))
|
|
(local tile (require :game.tiles))
|
|
(local entity (require :game.entity))
|
|
(local link (require :link))
|
|
(local {: lo : hi : readjson} (require :lib.util))
|
|
(local {: walkable} tile.flag-to-bit)
|
|
(local prg (asm.new))
|
|
|
|
(local tiles-org (prg:org 0x4100))
|
|
(local map-org (prg:org 0x4800))
|
|
(local font-org (prg:org 0x4900))
|
|
(local entity-org (prg:org 0x4b00))
|
|
(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: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 0x3d]
|
|
[: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
|
|
:lit :map 0x0c00 (vm:until 0x100 :-
|
|
:dup :yx>screen ; pmap yx pscreen
|
|
:<rot :drawmaprow :swap ; pmap yx
|
|
:dup :not) :drop :drop)
|
|
|
|
(vm:word :clearfooter
|
|
:lit :map 0x0300 (vm:until 0x100 :-
|
|
:dup 0x0900 :+ :yx>screen
|
|
:<rot :drawmaprow :swap
|
|
:dup :not) :drop :drop :object-redraw)
|
|
|
|
(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.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:word :draw-portrait ; pgfx
|
|
0x2252 :over :drawtile
|
|
0x2352 :over 32 :+ :drawtile
|
|
0x2254 :over 64 :+ :drawtile
|
|
0x2354 :swap 96 :+ :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 :touch-entity :not
|
|
(vm:when
|
|
:dup :itile-at :lookup-flags ; yxold yxnew flags
|
|
walkable :& (vm:when :swap)
|
|
)
|
|
: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 :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 font-org.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)
|
|
|
|
(fn with-footer [...] [:vm :drawfooter [:vm ...] :clearfooter])
|
|
(fn say [portrait ...]
|
|
(local result [:vm :lit (.. :p portrait) :draw-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))]))
|
|
(table.insert result :dismiss-dialog)
|
|
result)
|
|
|
|
(entity.install vm entity-org)
|
|
(vm:word :hello-world
|
|
entity.ev.touch := (vm:when
|
|
(with-footer
|
|
(say :jaye "THAT WAS AN EARTHQUAKE!")
|
|
(say :neut "GOLLY GEE JAYE, YOU'RE RIGHT!" "WHAT ARE WE GONNA DO??")
|
|
(say :jaye "WE" "MUST" "NOT" "PANIC!!"))))
|
|
|
|
(tile.appendtiles tiles-org)
|
|
|
|
; 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?
|
|
(local map (readjson "game/map00001.json"))
|
|
(tile.append-map map map-org)
|
|
(tile.appendgfx font-org (tile.loadgfx tile.fn-font))
|
|
(entity.append-from-map map entity-org)
|
|
|
|
(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)
|
|
|