SpindleyQ/honeylisp
1
1
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Merge branch 'projects'

Browse source
This commit is contained in:
Jeremy Penner 2021-06-26 13:49:20 -04:00
parent 0e488a751c 473f69302d
commit f3cb823e0f
88 changed files with 2842 additions and 684 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

BIN
8Bitsy.dsk Normal file
View file

Binary file not shown.

BIN
NeutTower.dsk
View file

Binary file not shown.

45
asm/asm.fnl
View file

@ -115,12 +115,13 @@
; takes the form [:op args] ; takes the form [:op args]
; pdat - a parsed dat; takes the form {:type type :addr addr ...} ; pdat - a parsed dat; takes the form {:type type :addr addr ...}
(local dat-parser {}) (local dat-parser {})
(fn new-block [] {:type :block :pdats [] :symbols {} :globals {}}) (fn new-block [last-symbol] {:type :block :pdats [] :preserved {} :symbols {} :globals {} : last-symbol})
(fn parse-dats [block dats] (fn parse-dats [block dats]
(each [_ dat (ipairs dats)] (each [_ dat (ipairs dats)]
(if (= (type dat) "string") (if (= (type dat) "string")
(do (tset block.symbols dat (+ (length block.pdats) 1)) (do (set block.last-symbol dat)
(tset block.symbols dat (+ (length block.pdats) 1))
(when (= (dat:sub 1 2) "G-") (when (= (dat:sub 1 2) "G-")
(tset block.globals dat true))) (tset block.globals dat true)))
@ -133,10 +134,15 @@
(if parser (parser dat block) (if parser (parser dat block)
(. opcodes opcode) (dat-parser.op dat) (. opcodes opcode) (dat-parser.op dat)
(error (.. "Unrecognized opcode " (fv opcode))))] (error (.. "Unrecognized opcode " (fv opcode))))]
(when pdat
(set pdat.nearest-symbol block.last-symbol)
(table.insert block.pdats pdat) (table.insert block.pdats pdat)
(when (and pdat pdat.globals) (when pdat.globals
(each [name _ (pairs pdat.globals)] (each [name _ (pairs pdat.globals)]
(tset block.globals name (length block.pdats))))))) (tset block.globals name (length block.pdats))))
(when pdat.preserved
(each [name pdat-preserved (pairs pdat.preserved)]
(tset block.preserved name pdat-preserved)))))))
block) block)
(fn dat-parser.op [op] (fn dat-parser.op [op]
@ -146,7 +152,7 @@
(fn dat-parser.block [block] (fn dat-parser.block [block]
(let [dats (lume.clone block)] (let [dats (lume.clone block)]
(table.remove dats 1) (table.remove dats 1)
(parse-dats (new-block) dats))) (parse-dats (new-block block.last-symbol) dats)))
(fn dat-parser.db [db] {:type :var :init (. db 2) :size 1}) (fn dat-parser.db [db] {:type :var :init (. db 2) :size 1})
(fn dat-parser.dw [dw] {:type :var :init (. dw 2) :size 2}) (fn dat-parser.dw [dw] {:type :var :init (. dw 2) :size 2})
@ -163,6 +169,13 @@
nil) nil)
(fn dat-parser.align [pad] {:type :pad :align (. pad 2)}) (fn dat-parser.align [pad] {:type :pad :align (. pad 2)})
(fn dat-parser.hot-preserve [[_ label & dats] block]
(let [preserve-block (new-block)]
(tset block.preserved label preserve-block)
(tset preserve-block.globals label true)
(parse-dats preserve-block [label])
(parse-dats preserve-block dats)
preserve-block))
(local pdat-processor { (local pdat-processor {
:op {} :op {}
@ -174,9 +187,11 @@
}) })
(fn process-pdat [pdat process default ...] (fn process-pdat [pdat process default ...]
; (pp pdat) (fn complain [ok ...]
(if ok (values ...)
(do (error (.. process " failed in " pdat.type " near " (or pdat.nearest-symbol "<start of block>") " @" (or pdat.addr "<no address>") " - " ...)))))
(local processor (. pdat-processor pdat.type process)) (local processor (. pdat-processor pdat.type process))
(if processor (processor pdat ...) default)) (if processor (complain (pcall #(processor pdat $...) ...)) default))
(fn pdat-processor.op.patch [op env] (fn pdat-processor.op.patch [op env]
(when (and op.mode (= (op.mode:sub 1 4) :addr)) (when (and op.mode (= (op.mode:sub 1 4) :addr))
@ -311,6 +326,7 @@
(or (self:env-lookup name :lookup-addr) (self:parse-addr name))) (or (self:env-lookup name :lookup-addr) (self:parse-addr name)))
:pass :pass
(fn [self passname] (fn [self passname]
(print passname)
(each [org block (pairs self.org-to-block)] (each [org block (pairs self.org-to-block)]
(: self passname org block (if self.prg-base (. self.prg-base.org-to-block org) nil)))) (: self passname org block (if self.prg-base (. self.prg-base.org-to-block org) nil))))
:gather-symbols :gather-symbols
@ -332,6 +348,21 @@
(self.dbgfile:close) (self.dbgfile:close)
(set self.dbgfile nil)) (set self.dbgfile nil))
self) self)
:read-hotswap
(fn [self machine]
(let [addr-to-label {}
addr-to-size {}]
(each [_ block (pairs self.org-to-block)]
(each [label pdat (pairs block.preserved)]
(tset addr-to-label pdat.addr label)
(tset addr-to-size pdat.addr pdat.size)))
(collect [addr bytes (pairs (machine:read-batch addr-to-size))]
(values (. addr-to-label addr) bytes))))
:write-hotswap
(fn [self machine hotswap]
(machine:write-batch
(collect [label bytes (pairs hotswap)]
(values (self:lookup-addr label) bytes))))
:upload :upload
(fn [self machine] (fn [self machine]
(if machine.upload (machine:upload self) (if machine.upload (machine:upload self)

2
asm/tape.fnl
View file

@ -25,7 +25,7 @@
(table.insert block :nextline) (table.insert block :nextline)
block) block)
(fn prg.dat-parser.basic [lines] (fn prg.dat-parser.basic [lines]
(local block (prg:new-block)) (local block (prg.new-block))
(each [_ line (ipairs (lume.slice lines 2))] (each [_ line (ipairs (lume.slice lines 2))]
(prg:parse-dats block [(parse-line line)])) (prg:parse-dats block [(parse-line line)]))
(prg:parse-dats block [[:dw 0]]) (prg:parse-dats block [[:dw 0]])

9
asm/vm.fnl
View file

@ -38,7 +38,7 @@
(fn install-vm-parser [prg] (fn install-vm-parser [prg]
(fn prg.dat-parser.vm [bytecodes] (fn prg.dat-parser.vm [bytecodes]
(local block (prg:new-block)) (local block (prg.new-block))
(each [_ bytecode (ipairs (lume.slice bytecodes 2))] (each [_ bytecode (ipairs (lume.slice bytecodes 2))]
(if (if
(= (type bytecode) :number) (= (type bytecode) :number)
@ -385,14 +385,15 @@
(fn vm.var [self name init] (fn vm.var [self name init]
(self.code:append name [:jsr :$dovar] (self.code:append name [:jsr :$dovar]
[:hot-preserve (.. :G-HOT-PRESERVE- name)
(if (= (type init) :table) init (if (= (type init) :table) init
[:dw init]))) [:dw init])]))
(vm:def :$doconst ; usage: [jsr :$doconst] followed by two bytes (vm:def :$doconst ; usage: [jsr :$doconst] followed by two bytes
(vm:reserve) (vm:reserve)
[:pla] [:sta vm.W] [:pla] [:sta vm.WH] [:pla] [:sta vm.W] [:pla] [:sta vm.WH]
[:ldy 1] [:lda [vm.W] :y] [:sta vm.TOP] [:ldy 1] [:lda [vm.W] :y] [:sta vm.TOP :x]
[:iny] [:lda [vm.W] :y] [:sta vm.TOPH]) [:iny] [:lda [vm.W] :y] [:sta vm.TOPH :x])
(fn vm.const [self name val] (fn vm.const [self name val]
(self.code:append name [:jsr :$doconst] (self.code:append name [:jsr :$doconst]

73
bitsy/boop.fnl Normal file
View file

@ -0,0 +1,73 @@
(local {: vm} (require :bitsy.defs))
(local speaker :0xc030)
(vm:def :blipmem ; count p --
[:block
[:lda [vm.ST1 :x]]
[:tay]
:sample
[:lda speaker]
[:lda [vm.TOP :x]]
[:inc vm.TOP :x]
[:bne :wait]
[:inc vm.TOPH :x]
:wait
[:clc] [:adc 1]
[:bne :wait]
[:dey]
[:bne :sample]]
(vm:drop) (vm:drop))
(vm:def :bliptone ; duration-f1 f2 --
[:block
[:lda vm.ST1H :x]
[:sta vm.W]
:top
[:lda speaker]
[:ldy vm.ST1 :x]
:wave1 [:dey] [:bne :wave1]
[:lda speaker]
[:lda vm.TOPH :x]
[:ldy vm.TOP :x] [:iny]
:wave2 [:dey] [:bne :wave2]
[:ldy 0xff]
[:sec] [:sbc 1] [:bcs :wave2]
[:dec vm.W]
[:bne :top]
(vm:drop) (vm:drop)])
; 0x39a "samples" = 440hz
(local notes {})
(each [i note (ipairs [:a :a# :b :c :c# :d :d# :e :f :f# :g :g#])]
(tset notes note (- i 1)))
(fn wavelength [note]
(-> 0x39a
(/ (math.pow 1.05946 (. notes note)))
(math.floor)))
(fn octave [wvl oct]
(-> wvl
(/ (math.pow 2 (- oct 3)))
(math.floor)))
(fn parse-note [n]
(values (n:sub 1 -2) (tonumber (n:sub -1))))
(fn note-wavelength [n]
(local (note oct) (parse-note n))
(-> (wavelength note)
(octave oct)))
(fn note [n ?duration ?timbre]
(local timbre (or ?timbre 0x20))
(local duration (or ?duration 0x10))
(local wvl (note-wavelength n))
[:vm (bit.bor (bit.lshift duration 8) timbre) (- wvl timbre) :bliptone])
(fn notes [ns ?duration ?timbre]
(local result [:block])
(each [_ n (ipairs ns)]
(table.insert result (note n ?duration ?timbre)))
result)
(vm:word :snd-explode 0x40 :lit :randombytes :blipmem)
(vm:word :snd-dooropen (notes [:c1 :e1] 3))
(vm:word :snd-doorclose (notes [:e1 :c1] 3))
(vm:word :snd-teleport (notes [:e4 :d#4 :d4 :g#4] 0x1a 0x50))
{: note : notes}

182
bitsy/defs.fnl Normal file
View file

@ -0,0 +1,182 @@
(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 files (require :game.files))
(local Prodos (require :asm.prodos))
(local actions (require :editor.actions))
(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 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]
[:db (length map.objects)]
[:dw (tiles.encode-yx map.player)]
[: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] [:hot-preserve :map-page [:db 0]])
(vm:word :map :lit :map-ptr :get)
(vm:word :entity-count :map 240 :+ :bget)
(vm:word :map-player-yx-ptr 241 :+)
(vm:word :map-player-yx :map :map-player-yx-ptr :get)
(vm:word :map-specific-tick :map 243 :+ :execute)
(vm:word :map-specific-move :map 246 :+ :execute)
(vm:word :map-specific-load :map 249 :+ :execute)
(fn generate-entity-code [level vm prefix]
(each [ientity entity (ipairs level.objects)]
(when (not entity.advanced)
(let [code []]
(each [iaction action (ipairs (or entity.steps []))]
(if action.condition (lume.push code (.. :cond- action.condition) (vm:when (actions.generate action vm iaction)))
(lume.push code (actions.generate action vm iaction))))
(vm:word (.. prefix ientity) :drop (table.unpack code))))))
(fn deflevel [ilevel 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 (. files.game.levels ilevel))
(local entity (require :bitsy.entity))
(append-map map org label)
(entity.append-from-map map org label)
(set level.vm.code org)
(generate-entity-code map level.vm (.. label "-entity-word-"))
level)
(fn say-runon [portrait ...]
(local result [:vm (.. :draw-portrait- 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)
(fn itile [label] (tiles.find-itile files.game.tiles label))
(set vm.code org.code)
{: vm : prg : mapw : maph : mon : org : achar : astr : style : rot8l : deflevel : say : say-runon : itile}

88
bitsy/disk.fnl Normal file
View file

@ -0,0 +1,88 @@
(local asm (require :asm.asm))
(local VM (require :asm.vm))
(local Prodos (require :asm.prodos))
(local util (require :lib.util))
(local {: lo : hi} util)
(local {: org} (require :bitsy.defs))
(fn append-boot-loader [prg]
(local vm prg.vm)
(set vm.code org.boot)
(set prg.files [])
(vm:word :loadfile ; length addr filename --
0xbb00 :open :read :drop :close)
(vm:word :loadscreen :cleargfx 0x2000 0x2000 :<rot :loadfile)
(vm.code:append
:boot
[:jsr :reset]
[:jsr :interpret]
[:vm :hires]
(when (util.file-exists "game/title.screen") [:vm (vm:pstr "TITLE.SCREEN") :loadscreen]))
(each [addr _ (pairs prg.org-to-block)]
(when (~= addr org.boot.org)
(local filename (.. "STUFF." (length prg.files)))
(table.insert prg.files {: filename :org addr})
(vm.code:append [:vm :lit [:dw #(length (. prg.org-to-block addr :bytes))] addr :lit (.. :filename (length prg.files)) :loadfile])))
(vm.code:append
[:vm :native]
[:jmp prg.start-symbol])
(each [i file (ipairs prg.files)]
(vm.code:append (.. :filename i) (Prodos.str file.filename))))
(fn org-copier [org]
(local srclabel (.. :loader- org.addr))
; this will always copy full pages, because it simplifies the code and we don't actually care if a little extra
; garbage is tacked on to the end.
; We copy the pages in reverse order, because this allows us to safely move from 0x2000 to higher memory, and we
; never want to overlap with 0x2000 from lower memory, so either direction is safe
(local dstpage-first (hi org.addr))
(local dstpage-last (hi (+ org.addr (length org.bytes) -1)))
[:block
[:computed :srchi #(+ ($1:lookup-addr :ld-src) 2)]
[:computed :dsthi #(+ ($1:lookup-addr :st-dst) 2)]
[:computed :src-last #(+ ($1:lookup-addr srclabel) (* (- dstpage-last dstpage-first) 0x100))]
[:computed :dst-last #(+ org.addr (* (- dstpage-last dstpage-first) 0x100))]
[:ldx 0]
:ld-src [:lda :src-last :x]
:st-dst [:sta :dst-last :x]
[:inx]
[:bne :ld-src]
[:lda :dsthi]
[:cmp dstpage-first]
[:beq :done]
[:dec :srchi]
[:dec :dsthi]
[:bne :ld-src]
:done])
(fn create-sys-loader [disk filename game]
(local blocks [])
(local prg (asm.new game))
(local sys (prg:org 0x2000))
(sys:append :loader-main)
(set prg.start-symbol :loader-main)
(sys:append (org-copier org.boot.block))
(sys:append [:jmp :boot])
(sys:append (.. :loader- org.boot.org) [:bytes org.boot.block.bytes])
(prg:assemble)
(disk:add-file (.. filename ".SYSTEM") Prodos.file-type.SYS 0x2000 sys.block.bytes))
(fn write [game]
(local disk (Prodos "ProDOS_Blank.dsk"))
(disk:update-volume-header {:name "EIGHTBITSY"})
(create-sys-loader disk :BITSY game)
(when (util.file-exists "game/title.screen")
(disk:add-file "TITLE.SCREEN" Prodos.file-type.BIN 0x2000 (: (util.readjson "game/title.screen") :fromhex)))
(each [_ file (ipairs game.files)]
(disk:add-file file.filename Prodos.file-type.BIN file.org (. game.org-to-block file.org :bytes)))
(disk:write "8Bitsy.dsk")
disk)
{: write : append-boot-loader}

111
bitsy/entity.fnl Normal file
View file

@ -0,0 +1,111 @@
(local util (require :lib.util))
(local tiles (util.require :game.tiles))
(local {: vm : org : itile : say : say-runon : controlstate} (require :bitsy.defs))
(local {: lo : hi} util)
; Entity memory layout:
; +0 - yx
; +2 - event handler
; +4 - link word
; +6 - link pointer
; All entities exist in a single page in RAM - with this structure we can have up to 32
; (players are handled specially and never require a link)
; The entity count for a level is stored after the map.
(local ev {
:touch 0
:noop -1
})
(vm:def :lookup-entity ; i -- entity
[:lda vm.TOP :x]
[:asl :a] [:asl :a] [:asl :a] ; x8
[:sta vm.TOP :x]
[:lda :map-page] [:clc] [:adc 1]
[:sta vm.TOPH :x])
(vm:word :entity-at ; yx -- entity|0
:>r 0 :entity-count
(vm:while [:dup] :dec ; entity|0 i
:dup :lookup-entity :get :rtop :=
(vm:when :lookup-entity :swap)
) :drop :rdrop)
(vm:var :responder 0)
(vm:word :get-responder :responder :get)
(vm:word :entity-itile :get :itile-at)
(vm:word :responder-itile :get-responder :entity-itile)
(vm:word :entity>do ; entity ev --
:over :responder :dup :get :>r :set
:swap 2 :+ :get :execute
:r> :responder :set)
(vm:word :link-arg ; e -- a
6 :+ :get)
(vm:word :linked-entity :get-responder :dup 4 :+ :get :dup (vm:if [:execute] [:drop :link-arg]))
(vm:word :entity-at>do ; yx ev -- f
:>r :entity-at :dup (vm:if [:r> :entity>do vm.true] [:rdrop]))
(vm:word :touch-entity ; yx -- f
ev.touch :entity-at>do)
(vm:word :untouch-entity ; yx --
ev.untouch :entity-at>do :drop)
(vm:word :entity-around>do ; yx ev --
:over 0x0100 :yx+ :over :entity-at>do :drop
:over 0x0001 :yx+ :over :entity-at>do :drop
:over 0xff00 :yx+ :over :entity-at>do :drop
:swap 0x00ff :yx+ :swap :entity-at>do :drop)
(vm:word :set-entitytile ; e itile --
:swap :get :swap :update-itile)
(vm:word :set-respondertile ; itile --
:get-responder :get :swap :update-itile)
; run only when processing an ev.touch event
(vm:word :transparent-entity-move ; -- f
:get-responder :get :dup :handle-general-move
:swap :over :not (vm:if [:move-player-to] [:drop]))
(vm:var :pre-handled-tile 0)
(vm:var :pre-handled-ev 0)
(vm:word :handle-onoff ; ev off on --
:responder-itile :pre-handled-tile :set :<rot
:dup ev.tog := (vm:when
:drop :dup :responder-itile := (vm:if [ev.deact] [ev.act])
) :dup :pre-handled-ev :set (vm:case
[ev.act :swap :drop :set-respondertile]
[ev.deact :drop :set-respondertile]
[:else :drop :drop]))
(vm:word :on-handled ; xp-on xp-off --
:responder-itile :pre-handled-tile :get := (vm:if
[:drop :drop]
[:pre-handled-ev :get ev.act :=
(vm:if [:drop] [:swap :drop]) :execute]))
(vm:word :activation-ev? ; ev -- f
:dup ev.act := :over ev.deact := :| :swap ev.tog := :|)
(vm:word :activate-link ; ev itile-on --
:swap :activation-ev? (vm:if [
:responder-itile := (vm:if [ev.act] [ev.deact])
:linked-entity :swap :entity>do
] [:drop]))
(vm:word :move-to-responder :get-responder :get :move-player-to)
(vm:word :disappear :get-responder 0 :set-entitytile 0xffff :get-responder :set)
(fn append-from-map [map entity-org prefix]
(entity-org:append [:align 0x100])
(each [ientity entity (ipairs map.objects)]
(when entity.name
(entity-org:append entity.name))
(entity-org:append
(.. prefix "-entity-" ientity)
[:db (- entity.x 1)] [:db (- entity.y 1)]
[:ref (if entity.advanced entity.func (.. prefix "-entity-word-" ientity))]
(if (and entity.advanced entity.linkword (> (length entity.linkword) 0)) [:ref entity.linkword] [:dw 0])
(if entity.link [:ref (.. prefix "-entity-" entity.link)]
(and entity.advanced entity.linkentity) [:ref entity.linkentity]
[:dw 0]))))
{: ev : append-from-map}

2
game/footer.fnl → bitsy/footer.fnl
View file

@ -1,4 +1,4 @@
(local {: vm : org} (require :game.defs)) (local {: vm : org} (require :bitsy.defs))
(local {: hi : lo} (require :lib.util)) (local {: hi : lo} (require :lib.util))
(vm:def :draw-pchar ; pscreen pchar -- (vm:def :draw-pchar ; pscreen pchar --

1
bitsy/game.json Normal file
View file

File diff suppressed because one or more lines are too long

127
bitsy/gfx.fnl Normal file
View file

@ -0,0 +1,127 @@
(local {: lo : hi} (require :lib.util))
(local {: vm : mapw : maph : org} (require :bitsy.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 :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:word :draw-portrait ; pgfx
0x2252 :over :drawtile
0x2352 :over 32 :+ :drawtile
0x2254 :over 64 :+ :drawtile
0x2354 :swap 96 :+ :drawtile)

60
bitsy/init.fnl Normal file
View file

@ -0,0 +1,60 @@
(local util (require :lib.util))
(local {: lo : hi : readjson} util)
(local tile (util.reload :game.tiles))
(local {: prg : vm : org : deflevel} (util.reload :bitsy.defs))
(local files (require :game.files))
(local disk (util.reload :bitsy.disk))
(util.reload :bitsy.gfx)
(util.reload :bitsy.footer)
(util.reload :bitsy.map)
(util.reload :bitsy.entity)
(util.reload :bitsy.player)
(util.reload :bitsy.boop)
(tile.appendtiles org.code)
(org.code:append [:align 0x100] :font)
(tile.appendgfx org.code files.game.font)
(tile.append-portraitwords vm)
(vm:var :tick-count)
(vm:word :handle-key :tick :read-key :player-key :hide-footer)
(vm:word :tick :map-specific-tick :tick-count :get 1 :+ :tick-count :set :player-redraw :rnd :drop)
(vm:var :next-level 0)
(vm:word :load-next-level :next-level :get :dup (vm:if [:load-level 0 :next-level :set] [:drop]))
(vm:word :load-level ; level-ptr --
:lit :map-ptr :set :reload-level)
(vm:word :reload-level
:map-player-yx :player-yx :set
:map-specific-load
:full-redraw)
(each [_ flag (ipairs (or files.game.flags []))]
(vm:var (.. :cond-var- flag) vm.false)
(vm:word (.. :cond- flag) (.. :cond-var- flag) :get))
(each [imap _ (ipairs files.game.levels)]
(deflevel imap (.. :map imap)))
(vm.code:append :main
[:jsr :reset]
[:jsr :interpret]
[:vm :hires
:lit :map1 :load-level
(vm:forever
(vm:hotswap-sync :full-redraw)
:interactive-eval-checkpoint
:handle-key
)
:quit])
(disk.append-boot-loader prg)
(print "assembling")
(prg:assemble)
(print "assembled")
(disk.write prg)
prg

2
game/map.fnl → bitsy/map.fnl
View file

@ -1,5 +1,5 @@
(local {: lo : hi} (require :lib.util)) (local {: lo : hi} (require :lib.util))
(local {: vm : mapw : maph : rot8l} (require :game.defs)) (local {: vm : mapw : maph : rot8l} (require :bitsy.defs))
(vm:def :lookup-flags ; itile -- flags (vm:def :lookup-flags ; itile -- flags
[:lda vm.TOP :x] [:lda vm.TOP :x]

80
bitsy/player.fnl Normal file
View file

@ -0,0 +1,80 @@
(local tile (require :game.tiles))
(local {: vm : mapw : maph : itile : controlstate} (require :bitsy.defs))
(local {: walkable} (tile.flag-to-bit))
(vm:word :either= ; target val1 val2 -- f
:>rot :over := :>rot := :|)
(vm:word :movement-dir ; key -- dyx
(vm:ifchain [:dup (string.byte "I") 0x0b :either=] [:drop 0xff00]
[:dup (string.byte "J") 0x08 :either=] [:drop 0x00ff]
[:dup (string.byte "K") 0x15 :either=] [:drop 0x0001]
[:dup (string.byte "M") 0x0a :either=] [:drop 0x0100]
[:drop 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 :player-yx 0x0a0a)
(vm:word :draw-player ; --
:player-yx :dup (vm:if [:get :dup 0xffff := (vm:if [:drop] [:yx>screen :player-tile :drawtile])] [:drop]))
(vm:var :noclip)
(vm:word :move-if-clear ; yx -- f
:noclip :get (vm:if [:drop vm.false] [:movable-player-flag :flag-at? :not]))
(vm:const :movable-player-flag ; -- flag
walkable)
(vm:word :move-player-to ; yx --
:player-yx :dup :get :dup 0xffff := (vm:if [:drop] [:drawtile-at])
:set :draw-player)
(vm:word :move-noop :drop vm.false)
(vm:word :handle-general-move ; yx -- f
(vm:if-or [[:dup :map-specific-move] [:dup :move-if-clear]]
[:drop vm.true] [:move-noop]))
(vm:def :yxclip? ; yx -- f
[:block
[:lda vm.TOP :x]
[:cmp mapw]
[:bcs :clipped]
[:lda vm.TOPH :x]
[:cmp maph]
[:bcs :clipped]
[:lda 0] [:sta vm.TOP :x] [:sta vm.TOPH :x] (vm:ret)
:clipped
[:lda 0xff] [:sta vm.TOP :x] [:sta vm.TOPH :x]])
(vm:word :try-move-player ; dir --
:player-yx :get :yx+ ; yxnew
(vm:if-or [[:dup :yxclip?] [:dup :touch-entity] [:dup :handle-general-move]]
[:drop :player-yx :get])
; always "move" so that player can visibly change direction
; touch-entity can modify player-yx so we have to refetch
:move-player-to)
(vm:word :two-frame :tick-count :get 0x1f :& 0x10 :<)
(vm:word :player-tile ; -- ptile
(itile :player-frame1) :lookup-tile)
(vm:word :flag-at? ; yx flag -- f
:swap :itile-at :lookup-flags :&)
(vm:word :player-key ; key --
(vm:ifchain [:movement-dir :dup] [:try-move-player :load-next-level]
[:drop]))
(vm:word :full-redraw :drawmap :player-redraw)
(vm:word :player-redraw :draw-player)

63
editor/8bitsy.fnl Normal file
View file

@ -0,0 +1,63 @@
(local util (require :lib.util))
(local actions (require :editor.actions))
(local {: textbox : dropdown : textfield} (util.require :editor.imstate))
(local files (require :game.files))
(local lume (require :lib.lume))
(local style (require :core.style))
(actions.register :say
(fn [action view x y w i]
(let [characters (lume.map files.game.portraits #$1.label)
character (or action.character (. characters 1))
lines (or action.lines [])
(character y) (dropdown view [:say :char i] character characters x (+ y style.padding.y) w)
(line1 y) (textbox view [:say :line1 i] (or (. lines 1) "") x (+ y style.padding.y) w)
(line2 y) (textbox view [:say :line2 i] (or (. lines 2) "") x y w)
(line3 y) (textbox view [:say :line3 i] (or (. lines 3) "") x y w)
(line4 y) (textbox view [:say :line4 i] (or (. lines 4) "") x y w)]
(set action.character character)
(util.nested-tset action [:lines 1] (line1:sub 1 33))
(util.nested-tset action [:lines 2] (line2:sub 1 33))
(util.nested-tset action [:lines 3] (line3:sub 1 33))
(util.nested-tset action [:lines 4] (line4:sub 1 33))
y))
(fn [action vm]
(local {: say} (require :bitsy.defs))
(say action.character (table.unpack (lume.map action.lines #($1:upper))))))
(actions.register :warp
(fn [action view x y w i]
(let [maps (icollect [imap _ (ipairs files.game.levels)] (.. :map imap))
map (or action.map (. maps 1))
y (+ y style.padding.y)
map (dropdown view [:warp :map i] map maps x y 100)
(position-string y) (textbox view [:warp :loc i] (string.format "%x" (or action.position 0)) (+ x 150) y 150)
position (or (tonumber position-string 16) action.position)]
(set action.map map)
(set action.position position)
y))
(fn [action vm]
(values :move-to-responder action.position :lit action.map :map-player-yx-ptr :set :lit action.map :next-level :set)))
(actions.register-const :move-here :move-to-responder)
(actions.register-const :disappear :disappear)
(actions.register :set-flag
(fn [action view x y w i]
(let [y (+ y style.padding.y)
x (renderer.draw_text style.font "Set " x y style.text)
flag (or action.flag (. files.game.flags 1))
flag (dropdown view [:set-flag :flag i] flag files.game.flags x y 100)
x (renderer.draw_text style.font " to " (+ x 100) y style.text)
options (lume.concat
[{:label "<Yes>" :value 0xffff} {:label "<No>" :value 0}]
(icollect [_ flag (ipairs files.game.flags)] {:label flag :value (.. :cond- flag)}))
rhs (or action.rhs (. options 1))
(rhs y) (dropdown view [:set-flag :rhs i] rhs options x y 100)]
(set action.flag flag)
(set action.rhs rhs)
y))
(fn [action vm]
(values action.rhs.value (.. :cond-var- action.flag) :set)))
{}

23
editor/actions.fnl Normal file
View file

@ -0,0 +1,23 @@
(local util (require :lib.util))
(local {: defmulti : defmethod} (util.require :lib.multimethod))
(local {: textfield} (util.require :editor.imstate))
(local actions (util.hot-table ...))
(set actions.edit (defmulti #$1.action :edit ...))
(set actions.generate (defmulti #$1.action :generate ...))
(defmethod actions.edit :default (fn [action view x y w i] y))
(fn actions.register [key edit generate]
(when (= actions.actionlist nil)
(set actions.actionlist []))
(lume.remove actions.actionlist key)
(table.insert actions.actionlist key)
(defmethod actions.edit key edit)
(defmethod actions.generate key generate))
(fn actions.register-const [key generated-value]
(actions.register key (fn [action view x y w i] y) #generated-value))
actions.hot

3
editor/fontedit.fnl
View file

@ -5,7 +5,6 @@
(local FontEditView (TileView:extend)) (local FontEditView (TileView:extend))
(fn FontEditView.spritegen [self] tiledraw.char-to-sprite)
(fn FontEditView.tilesize [self] (values 8 8)) (fn FontEditView.tilesize [self] (values 8 8))
(fn FontEditView.tilekeys [self] [:gfx]) (fn FontEditView.tilekeys [self] [:gfx])
(fn FontEditView.map-bitxy [self x y] (values y x)) (fn FontEditView.map-bitxy [self x y] (values y x))
@ -14,7 +13,7 @@
(local char (string.char (+ self.itile 0x20 -1))) (local char (string.char (+ self.itile 0x20 -1)))
(renderer.draw_text style.big_font char x y style.text)) (renderer.draw_text style.big_font char x y style.text))
(love.graphics.setColor 1 1 1 1)) (love.graphics.setColor 1 1 1 1))
(fn FontEditView.filename [self] tiles.fn-font) (fn FontEditView.resource-key [self] :font)
(fn FontEditView.get_name [self] "Font Editor") (fn FontEditView.get_name [self] "Font Editor")
FontEditView FontEditView

13
editor/gfxedit.fnl
View file

@ -2,6 +2,7 @@
(local tiles (require :game.tiles)) (local tiles (require :game.tiles))
(local tiledraw (require :editor.tiledraw)) (local tiledraw (require :editor.tiledraw))
(local util (require :lib.util)) (local util (require :lib.util))
(local files (require :game.files))
(local {: attach-imstate : mouse-inside : activate : active? : button} (util.require :editor.imstate)) (local {: attach-imstate : mouse-inside : activate : active? : button} (util.require :editor.imstate))
(local GraphicsEditView (View:extend)) (local GraphicsEditView (View:extend))
@ -11,15 +12,17 @@
(fn GraphicsEditView.new [self] (fn GraphicsEditView.new [self]
(GraphicsEditView.super.new self) (GraphicsEditView.super.new self)
(set self.tilecache (tiledraw.TileCache (tiles.loadgfx (self:filename)) (self:spritegen))) (set self.tilecache (files.cache (self:resource-key)))
(set self.itile 1) (set self.itile 1)
(set self.scrollheight math.huge)
(set self.scrollable true)
(attach-imstate self)) (attach-imstate self))
(fn GraphicsEditView.spritegen [self] tiledraw.tile-to-sprite) (fn GraphicsEditView.get_scrollable_size [self] self.scrollheight)
(fn GraphicsEditView.resource-key [self] :tiles)
(fn GraphicsEditView.tilesize [self] (values 16 16)) (fn GraphicsEditView.tilesize [self] (values 16 16))
(fn GraphicsEditView.tilebytelen [self] (let [(w h) (self:tilesize)] (/ (* w h) 8))) (fn GraphicsEditView.tilebytelen [self] (let [(w h) (self:tilesize)] (/ (* w h) 8)))
(fn GraphicsEditView.filename [self] tiles.fn-tiles) (fn GraphicsEditView.reload [self] (files.reload))
(fn GraphicsEditView.reload [self] (fn GraphicsEditView.save [self] (files.save))
(self.tilecache:load (tiles.loadgfx (self:filename))))
(fn GraphicsEditView.select-rel [self ditile] (fn GraphicsEditView.select-rel [self ditile]
(when self.itile (when self.itile

75
editor/imstate.fnl
View file

@ -23,6 +23,10 @@
(fn view.draw [self] (fn view.draw [self]
(set self.cursor nil) (set self.cursor nil)
(self.__index.draw self) (self.__index.draw self)
(when self.imstate.postponed
(each [_ action (ipairs self.imstate.postponed)]
(action))
(set self.imstate.postponed nil))
(when (= self.cursor nil) (set self.cursor :arrow)) (when (= self.cursor nil) (set self.cursor :arrow))
(set self.imstate.keys nil) (set self.imstate.keys nil)
(set self.imstate.text nil) (set self.imstate.text nil)
@ -57,6 +61,11 @@
(fn [] (when (= (-?> core.active_view.imstate (. :focus)) nil) (fn [] (when (= (-?> core.active_view.imstate (. :focus)) nil)
(p-fn)))) (p-fn))))
(fn postpone [view f]
(when (= view.imstate.postponed nil)
(set view.imstate.postponed []))
(table.insert view.imstate.postponed f))
(fn make-tag [tag] (fn make-tag [tag]
(match (type tag) (match (type tag)
:string tag :string tag
@ -67,20 +76,29 @@
(local (mx my) (values (love.mouse.getX) (love.mouse.getY))) (local (mx my) (values (love.mouse.getX) (love.mouse.getY)))
(and (>= mx x) (<= mx (+ x w)) (>= my y) (<= my (+ y h)))) (and (>= mx x) (<= mx (+ x w)) (>= my y) (<= my (+ y h))))
(fn consume-pressed [view button]
(when (= (. view.imstate button) :pressed)
(tset view.imstate button :down)
true))
(fn activate [view tag x y w h] (fn activate [view tag x y w h]
(when (and (= view.imstate.left :pressed) (mouse-inside x y w h)) (when (and (mouse-inside x y w h) (consume-pressed view :left))
(set view.imstate.active (make-tag tag)) (set view.imstate.active (make-tag tag))
true)) true))
(fn set-cursor [view cursor]
(when (= view.cursor nil) (set view.cursor cursor)))
(fn active? [view tag] (= view.imstate.active (make-tag tag))) (fn active? [view tag] (= view.imstate.active (make-tag tag)))
(fn button [view tag x y w h] (fn button [view tag x y w h]
(when (mouse-inside x y w h) (set view.cursor :hand)) (when (mouse-inside x y w h) (set-cursor view :hand))
(activate view tag x y w h) (activate view tag x y w h)
(and (active? view tag) (= view.imstate.left :released) (mouse-inside x y w h))) (values (and (active? view tag) (= view.imstate.left :released) (mouse-inside x y w h)) (+ y h style.padding.y)))
(fn textbutton [view label x y] (fn textbutton [view label x y]
(local (w h) (values (+ (style.font:get_width label) 8) 24)) (local (w h) (values (+ (style.font:get_width label) style.padding.x) (+ (style.font:get_height) style.padding.y)))
(renderer.draw_rect x y w h style.selection) (renderer.draw_rect x y w h style.selection)
(renderer.draw_text style.font label (+ x 4) (+ y 4) style.text) (renderer.draw_text style.font label (+ x (/ style.padding.x 2)) (+ y (/ style.padding.y 2)) style.text)
(values (button view label x y w h) (+ y h))) (values (button view label x y w h) (+ y h)))
(fn checkbox [view name isset x y ?tag] (fn checkbox [view name isset x y ?tag]
@ -89,14 +107,14 @@
(love.graphics.setColor 1 1 1 1) (love.graphics.setColor 1 1 1 1)
(button view (or ?tag name) x y (- xEnd x) 12)) (button view (or ?tag name) x y (- xEnd x) 12))
(fn focused? [view tag] (= tag (-?> view.imstate.focus (. :tag)))) (fn focused? [view tag] (= (make-tag tag) (-?> view.imstate.focus (. :tag))))
(fn focus [view tag x y w h opts] (fn focus [view tag x y w h opts]
(if (activate view tag x y w h) (if (activate view tag x y w h)
(set view.imstate.focus (set view.imstate.focus
(doto (lume.clone (or opts {})) (doto (lume.clone (or opts {}))
(tset :tag tag))) (tset :tag (make-tag tag))))
(and (= view.imstate.left :released) (focused? view tag) (not (active? view tag))) (and (= view.imstate.left :released) (focused? view tag) (not (mouse-inside x y w h)))
(set view.imstate.focus nil)) (set view.imstate.focus nil))
(focused? view tag)) (focused? view tag))
@ -155,11 +173,14 @@
(fn textbox [view tag text x y w] (fn textbox [view tag text x y w]
(var textNew (or text "")) (var textNew (or text ""))
(local (h hText xText yText) (values 20 16 (+ x 2) (+ y 2))) (local (h hText xText yText) (values (+ (style.font:get_height) 4) (style.font:get_height) (+ x 2) (+ y 2)))
(local initial-press (= view.imstate.left :pressed))
; handle key events ; handle key events
(when (focus view tag x y w h {:i 1 :iAnchor 1 :blink (love.timer.getTime)}) (when (focus view tag x y w h {:i 1 :iAnchor 1 :blink (love.timer.getTime)})
(local f view.imstate.focus) (local f view.imstate.focus)
(when (> f.i (+ (length text) 1)) (set f.i (+ (length text) 1)))
(when (> f.iAnchor (+ (length text) 1)) (set f.iAnchor (+ (length text) 1)))
(when view.imstate.text (when view.imstate.text
(set textNew (replace-selection view textNew view.imstate.text))) (set textNew (replace-selection view textNew view.imstate.text)))
(each [_ key (ipairs (or view.imstate.keys []))] (each [_ key (ipairs (or view.imstate.keys []))]
@ -179,10 +200,10 @@
(set textNew (replace-selection view textNew "" iStartDel iLimDel))))))) (set textNew (replace-selection view textNew "" iStartDel iLimDel)))))))
; handle mouse events ; handle mouse events
(when (mouse-inside x y w h) (set view.cursor :ibeam)) (when (mouse-inside x y w h) (set-cursor view :ibeam))
(when (and (focused? view tag) (active? view tag) (mouse-inside x y w h)) (when (and (focused? view tag) (active? view tag) (mouse-inside x y w h))
(local mouse-i (i-from-x textNew (love.mouse.getX) x style.font)) (local mouse-i (i-from-x textNew (love.mouse.getX) x style.font))
(when (= view.imstate.left :pressed) (when initial-press
(set view.imstate.focus.iAnchor mouse-i)) (set view.imstate.focus.iAnchor mouse-i))
(set view.imstate.focus.i mouse-i)) (set view.imstate.focus.i mouse-i))
@ -212,4 +233,34 @@
(renderer.draw_text style.font label x y style.text) (renderer.draw_text style.font label x y style.text)
(textbox view label text (+ x wLabel) y wText)) (textbox view label text (+ x wLabel) y wText))
{: attach-imstate : cmd-predicate : mouse-inside : activate : active? : button : checkbox : textbox : textfield : textbutton} (fn option-text [option]
(match (type option)
:string option
:table (or option.label (tostring option))
_ (tostring option)))
(fn dropdown [view tag selection options x y w]
(local row-h (+ (style.font:get_height) style.padding.y))
(var new-selection nil)
(renderer.draw_rect x y w row-h style.selection)
(renderer.draw_text style.font (option-text selection) (+ x style.padding.x) (+ y (/ style.padding.y 2)) style.text)
(renderer.draw_text style.icon_font "-" (+ x w (- style.padding.x)) (+ y (/ style.padding.y 2)) style.text)
(when (focused? view tag)
(var row-y (+ y row-h))
(each [i option (ipairs options)]
(when (button view [(make-tag tag) i] x row-y w row-h)
(set new-selection option))
(set row-y (+ row-y row-h)))
(postpone view (fn []
(var row-y (+ y row-h))
(each [i option (ipairs options)]
(renderer.draw_rect x row-y w row-h style.selection)
(renderer.draw_text style.font (option-text option) (+ x style.padding.x) (+ row-y (/ style.padding.y 2)) style.text)
(set row-y (+ row-y row-h))))))
(focus view tag x y w row-h)
(values (or new-selection selection) (+ y row-h)))
{: attach-imstate : cmd-predicate : postpone : mouse-inside : activate : active?
: button : checkbox : textbox : textfield : textbutton : dropdown}

24
editor/init.fnl
View file

@ -9,8 +9,11 @@
(local keymap (require :core.keymap)) (local keymap (require :core.keymap))
(local common (require :core.common)) (local common (require :core.common))
(require :editor.8bitsy)
(require :presentation.commands)
(let [commands {}] (let [commands {}]
(each [_ name (ipairs [:tile :portrait :font :brush])] (each [_ name (ipairs [:tile :portrait :font :brush :map])]
(local cls (require (.. "editor." name "edit"))) (local cls (require (.. "editor." name "edit")))
(tset commands (.. "honeylisp:" name "-editor") (fn [] (tset commands (.. "honeylisp:" name "-editor") (fn []
(local node (core.root_view:get_active_node)) (local node (core.root_view:get_active_node))
@ -18,8 +21,7 @@
(command.add nil commands)) (command.add nil commands))
(local fileeditors (local fileeditors
{:map {:view MapEditView :filefilter "^game/map%d+%.json"} {:screen {:view ScreenEditView :filefilter ".*%.screen"}})
:screen {:view ScreenEditView :filefilter "^game/.*%.screen"}})
(each [type {: view : filefilter} (pairs fileeditors)] (each [type {: view : filefilter} (pairs fileeditors)]
(command.add nil (command.add nil
@ -57,6 +59,22 @@
"ctrl+v" "tileedit:paste" "ctrl+v" "tileedit:paste"
}) })
(command.add :editor.replview {
"repl:submit" #(core.active_view:submit)
})
(local ReplView (require :editor.replview))
(local repl (require :editor.repl))
(command.add nil {
"repl:create" (fn []
(local node (core.root_view:get_active_node))
(node:add_view (ReplView (repl.new)))
)
})
(keymap.add {
:return "repl:submit"
})
(fn inline-eval [eval] (fn inline-eval [eval]
(let [ldoc core.active_view.doc (let [ldoc core.active_view.doc
(aline acol bline bcol) (ldoc:get_selection) (aline acol bline bcol) (ldoc:get_selection)

172
editor/mapedit.fnl
View file

@ -2,9 +2,11 @@
(local style (require :core.style)) (local style (require :core.style))
(local util (require :lib.util)) (local util (require :lib.util))
(local lume (require :lib.lume)) (local lume (require :lib.lume))
(local {: mouse-inside : activate : active? : checkbox : textfield : textbutton} (util.require :editor.imstate)) (local files (require :game.files))
(local {: mouse-inside : activate : active? : checkbox : textfield : textbutton : textbox : dropdown} (util.require :editor.imstate))
(local {: tilestrip-to-sprite} (util.require :editor.tiledraw)) (local {: tilestrip-to-sprite} (util.require :editor.tiledraw))
(local {: encode-yx : encode-itile : decode-itile} (util.require :game.tiles)) (local {: encode-yx : encode-itile : decode-itile} (util.require :game.tiles))
(local actions (require :editor.actions))
(local MapEditView (GraphicsEditView:extend)) (local MapEditView (GraphicsEditView:extend))
(local sprite-scale 3) (local sprite-scale 3)
@ -13,11 +15,11 @@
(local tilew (* sprite-scale 14)) (local tilew (* sprite-scale 14))
(local tileh (* sprite-scale 16)) (local tileh (* sprite-scale 16))
(fn MapEditView.new [self filename] (fn MapEditView.new [self]
(MapEditView.super.new self) (MapEditView.super.new self)
(set self.sprite-scale sprite-scale) (set self.sprite-scale sprite-scale)
(set self.stripcache {}) (set self.stripcache {})
(set self.mapfilename filename) (set self.ilevel 1)
(self:reload)) (self:reload))
; map is stored bottom-to-top ; map is stored bottom-to-top
@ -58,6 +60,18 @@
(when (. objects (+ iobjectsrc 1)) (when (. objects (+ iobjectsrc 1))
(move-object objects (+ iobjectsrc 1) iobjectsrc))) (move-object objects (+ iobjectsrc 1) iobjectsrc)))
(fn MapEditView.draw-map-selector [self x y]
(renderer.draw_text style.font "Map" x (+ y (/ style.padding.y 2)) style.text)
(let [options {}
level-count (length files.game.levels)
_ (do (for [i 1 level-count] (tset options i i))
(table.insert options :New))
(ilevel yNext) (dropdown self :map-selector self.ilevel options (+ x 50) y 100)]
(when (not= ilevel self.ilevel)
(set self.ilevel (if (= ilevel :New) (+ level-count 1) ilevel))
(self:load-level))
(- yNext y)))
(fn MapEditView.linking-obj [self] (. self.level.objects self.iobject-linking)) (fn MapEditView.linking-obj [self] (. self.level.objects self.iobject-linking))
(fn MapEditView.draw-link-line [self x y iobjectSrc color toMouse?] (fn MapEditView.draw-link-line [self x y iobjectSrc color toMouse?]
(local objectSrc (. self.level.objects iobjectSrc)) (local objectSrc (. self.level.objects iobjectSrc))
@ -79,7 +93,7 @@
(var stripid "") (var stripid "")
(for [mx 1 mapw] (for [mx 1 mapw]
(local itile (self:itile-from-xy mx my)) (local itile (self:itile-from-xy mx my))
(local tile (. self.tilecache.tiles itile :gfx)) (local tile (?. self.tilecache.tiles itile :gfx))
(table.insert tilestrip tile) (table.insert tilestrip tile)
(set stripid (.. stripid (string.char itile)))) (set stripid (.. stripid (string.char itile))))
(var sprite (. self.stripcache stripid)) (var sprite (. self.stripcache stripid))
@ -89,6 +103,8 @@
(love.graphics.draw sprite x y 0 self.sprite-scale self.sprite-scale)) (love.graphics.draw sprite x y 0 self.sprite-scale self.sprite-scale))
(fn MapEditView.draw-map-editor [self x y] (fn MapEditView.draw-map-editor [self x y]
(love.graphics.setColor 1 1 1 1)
(local button-state self.imstate.left)
(activate self :map x y (* tilew mapw) (* tileh maph)) (activate self :map x y (* tilew mapw) (* tileh maph))
(var iobject-over nil) (var iobject-over nil)
(for [my 1 maph] (for [my 1 maph]
@ -99,7 +115,7 @@
(local itile (self:itile-from-xy mx my)) (local itile (self:itile-from-xy mx my))
(local iobject (self:iobject-from-xy mx my)) (local iobject (self:iobject-from-xy mx my))
(when (= self.itile nil) (when (= self.itile nil)
(each [_ player (ipairs [:jaye :neut])] (each [_ player (ipairs (or files.game.players [:player]))]
(match (. self.level player) (match (. self.level player)
{:x mx :y my} (renderer.draw_text style.font player tilex tiley style.text))) {:x mx :y my} (renderer.draw_text style.font player tilex tiley style.text)))
(love.graphics.setColor 1 1 1)) (love.graphics.setColor 1 1 1))
@ -115,7 +131,7 @@
(when (and self.itile (active? self :map) (mouse-inside tilex tiley tilew tileh) (not= itile self.itile)) (when (and self.itile (active? self :map) (mouse-inside tilex tiley tilew tileh) (not= itile self.itile))
(self:set-tile mx my self.itile)) (self:set-tile mx my self.itile))
(when (and (= self.itile nil) (active? self :map) (mouse-inside tilex tiley tilew tileh)) (when (and (= self.itile nil) (active? self :map) (mouse-inside tilex tiley tilew tileh))
(match self.imstate.left (match button-state
:pressed (set self.iobject-linking iobject) :pressed (set self.iobject-linking iobject)
:released :released
(if (and (not= iobject nil) (= self.iobject-linking iobject)) (if (and (not= iobject nil) (= self.iobject-linking iobject))
@ -140,64 +156,116 @@
(if (= self.imstate.left :released) (set self.iobject-linking nil) (if (= self.imstate.left :released) (set self.iobject-linking nil)
(self:draw-link-line x y self.iobject-linking [0 1 0] true))))) (self:draw-link-line x y self.iobject-linking [0 1 0] true)))))
(fn MapEditView.draw-object-editor [self x y] (fn condition-label [flag]
(if flag {:label flag : flag} {:label "<always>"}))
(fn condition-options []
(let [options [(condition-label nil)]]
(each [_ flag (ipairs (or files.game.flags []))]
(table.insert options (condition-label flag)))
options))
(fn MapEditView.draw-object-code-editor [self object x y]
(var y y) (var y y)
(local object (self:object)) (var istep-to-delete nil)
(set (object.func y) (textfield self "Word" object.func x y 100 200)) (when (not object.steps) (set object.steps []))
(set (object.name y) (textfield self "Name" object.name x (+ y 5) 100 200)) (each [istep step (ipairs object.steps)]
(set (object.linkword y) (textfield self "Link word" object.linkword x (+ y 5) 100 200)) (when (textbutton self "X" (+ x 280) y)
(if object.link (set istep-to-delete istep))
(match (textbutton self "Unlink" x (+ y 5)) (set step.condition (. (dropdown self [:code-condition istep] (condition-label step.condition) (condition-options)
(unlink yNext) (do (when unlink (set object.link nil)) (+ x 100 style.padding.x) y 100)
(set y yNext))) :flag))
(set (object.linkentity y) (textfield self "Link entity" object.linkentity x (+ y 5) 100 200))) (set (step.action y) (dropdown self [:code-action istep] (or step.action (. actions.actionlist 1)) actions.actionlist x y 100))
(when (textbutton self "Delete" x (+ y 40)) (set y (actions.edit step self x y 300 istep))
(set y (+ y style.padding.y)))
(when istep-to-delete (table.remove object.steps istep-to-delete))
(let [(do-new y) (textbutton self "+ New Step" x (+ y style.padding.y))]
(when do-new (table.insert object.steps {}))
y))
(fn advanced? [object]
(or object.advanced
(and (= object.advanced nil)
object.func)))
(fn MapEditView.draw-object-advanced-editor [self object x y]
(let [(func y) (textfield self "Word" object.func x y 100 200)
(name y) (textfield self "Name" object.name x (+ y style.padding.y) 100 200)
(linkword y) (textfield self "Link word" object.linkword x (+ y style.padding.y) 100 200)
(do-unlink y) (if object.link (textbutton self "Unlink" x (+ y style.padding.y)) (values false y))
(linkentity y) (if object.link (values object.linkentity y) (textfield self "Link entity" object.linkentity x (+ y style.padding.y) 100 200))]
(lume.extend object {: func : name : linkword : linkentity})
(when do-unlink (set object.link nil))
y))
(fn MapEditView.draw-object-editor [self x y]
(let [object (self:object)
y (if (advanced? object)
(self:draw-object-advanced-editor object x y)
(self:draw-object-code-editor object x y))
new-flag-name (textbox self :new-flag-name self.new-flag-name x (+ y style.padding.y) 200)
(mk-new-flag y) (textbutton self "+ New Flag" (+ x 200 style.padding.x) (+ y style.padding.y))
do-delete (textbutton self "Delete" x (+ y 40))
(do-advanced y) (textbutton self (if (advanced? object) "Simple" "Advanced") (+ x 150) (+ y 40))]
(set self.new-flag-name new-flag-name)
(when mk-new-flag
(when (= files.game.flags nil)
(set files.game.flags []))
(table.insert files.game.flags new-flag-name)
(set self.new-flag-name ""))
(when do-delete
(move-object self.level.objects (+ self.iobject 1) self.iobject) (move-object self.level.objects (+ self.iobject 1) self.iobject)
(set self.iobject nil))) (set self.iobject nil))
(when do-advanced (set object.advanced (not (advanced? object))))
y))
(fn MapEditView.load-level [self]
(set self.stripcache {})
(when (= (. files.game.levels self.ilevel) nil)
(tset files.game.levels self.ilevel {:map (string.rep "\0" (* mapw maph)) :objects []}))
(set self.level (. files.game.levels self.ilevel))
(set self.iobject nil))
(fn MapEditView.reload [self] (fn MapEditView.reload [self]
(MapEditView.super.reload self) (MapEditView.super.reload self)
(local (loaded level) (pcall #(util.readjson self.mapfilename))) (self:load-level))
(set self.level
(match (and loaded (type level))
false {:map (string.rep "\0" (* mapw maph)) :objects []}
:string {:map (level:fromhex) :objects []}
:table (doto level (tset :map (level.map:fromhex))))))
(fn MapEditView.save [self]
(util.writejson self.mapfilename
(doto (lume.clone self.level)
(tset :map (self.level.map:tohex)))))
(fn MapEditView.draw [self] (fn MapEditView.draw [self]
(var x (+ self.position.x 10)) (var x (+ self.position.x style.padding.x (- self.scroll.x)))
(var y (+ self.position.y 10)) (var y (+ self.position.y style.padding.y (- self.scroll.y)))
(self:draw_background style.background) (self:draw_background style.background)
(love.graphics.setColor 1 1 1 1) (self:draw_scrollbar)
(local ytop y)
(set y (+ y (self:draw-map-selector x y) style.padding.y))
(self:draw-map-editor x y) (self:draw-map-editor x y)
(when self.iobject (set y (+ y (* tileh maph) style.padding.y))
(self:draw-object-editor (+ x (* tilew mapw) 10) y)) (set y (+ y (self:draw-tile-selector x y (- self.size.x (* style.padding.x 2)))))
(set y (+ y (* tileh maph) 10))
(set self.level.tickword (textfield self "Tick word" self.level.tickword x y 100 200)) (set (self.level.tickword y) (textfield self "Tick word" self.level.tickword x (+ y style.padding.y) 100 200))
(set y (+ y 30)) (set (self.level.moveword y) (textfield self "Move word" self.level.moveword x (+ y style.padding.y) 100 200))
(set self.level.moveword (textfield self "Move word" self.level.moveword x y 100 200)) (set (self.level.loadword y) (textfield self "Load word" self.level.loadword x (+ y style.padding.y) 100 200))
(set y (+ y 30)) (let [(checked y-new) (checkbox self "Edit objects" (= self.itile nil) x (+ y style.padding.y))
(set self.level.loadword (textfield self "Load word" self.level.loadword x y 100 200)) _ (when checked
(set y (+ y 30))
(when (checkbox self "Edit objects" (= self.itile nil) x y)
(set self.itile nil) (set self.itile nil)
(set self.playerpos nil)) (set self.playerpos nil))]
(set y (+ y 30)) (set y y-new)
(each [_ player (ipairs [:jaye :neut])] (each [_ player (ipairs (or files.game.players [:player]))]
(when (checkbox self (.. "Position " player) (and (= self.itile nil) (= self.playerpos player)) x y) (let [(checked y-new) (checkbox self (.. "Position " player) (and (= self.itile nil) (= self.playerpos player)) x (+ y style.padding.y))]
(when checked
(set self.itile nil) (set self.itile nil)
(set self.playerpos player)) (set self.playerpos player))
(set y (+ y 30))) (set y y-new))))
(when (checkbox self "Start with Gord" self.level.gord-following x y) (each [_ levelflag (ipairs (or files.game.levelflags []))]
(set self.level.gord-following (not self.level.gord-following))) (let [(checked y-new) (checkbox self levelflag (. self.level levelflag) x (+ y style.padding.y))]
(set y (+ y 30)) (when checked (tset self.level levelflag (not (. self.level levelflag))))
(self:draw-tile-selector x y (- self.size.x 20))) (set y y-new)))
(when self.iobject
(set y (math.max y (if (> self.size.x (+ (* tilew mapw) 300))
(self:draw-object-editor (+ x (* tilew mapw) style.padding.x) ytop)
(self:draw-object-editor x (+ y style.padding.y))))))
(fn MapEditView.get_name [self] (.. "Map: " self.mapfilename)) (set self.scrollheight (- y (+ self.position.y style.padding.y (- self.scroll.y)))))
(fn MapEditView.get_name [self] (.. "Map " self.ilevel))
MapEditView MapEditView

3
editor/portraitedit.fnl
View file

@ -6,10 +6,9 @@
(local PortraitView (TileView:extend)) (local PortraitView (TileView:extend))
(fn PortraitView.spritegen [self] tiledraw.portrait-to-sprite)
(fn PortraitView.tilesize [self] (values 32 32)) (fn PortraitView.tilesize [self] (values 32 32))
(fn PortraitView.tilekeys [self] [:gfx]) (fn PortraitView.tilekeys [self] [:gfx])
(fn PortraitView.filename [self] tiles.fn-portraits) (fn PortraitView.resource-key [self] :portraits)
(fn PortraitView.map-bitxy [self x y] (fn PortraitView.map-bitxy [self x y]
(local quadrant (+ (if (>= x 16) 2 0) (if (>= y 16) 1 0))) (local quadrant (+ (if (>= x 16) 2 0) (if (>= y 16) 1 0)))
(local tilex (local tilex

49
editor/repl.fnl Normal file
View file

@ -0,0 +1,49 @@
(local util (require :lib.util))
(local fennel (require :lib.fennel))
(local style (require :core.style))
(local lume (require :lib.lume))
(local {: textbutton} (util.require :editor.imstate))
(local {: inspect} (util.require :inspector))
(local repl (util.hot-table ...))
(fn repl.inspector [{: vals : states} view x y]
(var h 0)
(each [i v (ipairs vals)]
(set h (+ h (inspect (. states i) v view x (+ y h) view.size.x))))
(+ h style.padding.y))
(fn repl.notify [listeners line]
(each [_ listener (ipairs listeners)]
(listener:append line)))
(fn repl.mk-result [vals]
(local inspector #(repl.inspector $...))
{:draw inspector : vals :states (icollect [_ (ipairs vals)] {})})
(fn repl.run [{: listeners}]
(fennel.repl {:readChunk coroutine.yield
:onValues #(repl.notify listeners (repl.mk-result $1))
:onError (fn [errType err luaSource] (repl.notify listeners (repl.mk-result [err])))
:pp #$1
:env (lume.clone _G)}))
(fn repl.listen [{: listeners} listener]
(table.insert listeners listener))
(fn repl.unlisten [{: listeners} listener]
(lume.remove listeners listener))
(fn repl.submit [{: coro} chunk]
(coroutine.resume coro (.. chunk "\n")))
(fn repl.new []
(local result
{:listeners []
:listen #(repl.listen $...)
:unlisten #(repl.unlisten $...)
:submit #(repl.submit $...)
:coro (coroutine.create repl.run)})
(coroutine.resume result.coro result)
result)
repl.hot

61
editor/replview.fnl Normal file
View file

@ -0,0 +1,61 @@
(local util (require :lib.util))
(local {: attach-imstate : textbox} (util.require :editor.imstate))
(local View (require :core.view))
(local style (require :core.style))
(local ReplView (View:extend))
(fn ReplView.new [self conn]
(ReplView.super.new self)
(attach-imstate self)
(set self.conn conn)
(set self.log [])
(set self.cmd "")
(set self.scrollheight math.huge)
(set self.scrollable true)
(self.conn:listen self))
(fn ReplView.try_close [self do_close]
(self.conn:unlisten self)
(ReplView.super.try_close self do_close))
(fn ReplView.get_scrollable_size [self] self.scrollheight)
(fn ReplView.append [self line]
(table.insert self.log line))
(fn ReplView.draw-cmd [{: cmd} view x y]
(renderer.draw_text style.font cmd x y style.text)
(+ (style.font:get_height) style.padding.y))
(fn ReplView.submit [self ?cmd]
(local cmd (or ?cmd self.cmd))
(when (= ?cmd nil)
(set self.cmd ""))
(self:append {:draw #(self.draw-cmd $...) : cmd})
(self.conn:submit cmd))
(fn ReplView.draw [self]
(self:draw_background style.background)
(self:draw_scrollbar)
(var x (- self.position.x self.scroll.x))
(var y (- self.position.y self.scroll.y))
(var rendered-h 0)
; todo: cache sizes and avoid drawing if offscreen?
; note: then offscreen items can't be focussed without further effort
; todo: draw line numbers
(each [i line (ipairs self.log)]
(let [h (line:draw self x y)]
(set y (+ y h))
(set rendered-h (+ rendered-h h))))
(set self.cmd (textbox self :command self.cmd x y self.size.x))
(local pin-to-bottom (>= self.scroll.to.y (- self.scrollheight self.size.y)))
(set self.scrollheight (+ rendered-h (style.font:get_height) 4))
(when pin-to-bottom
(set self.scroll.to.y (- self.scrollheight self.size.y))))
ReplView

17
editor/tileedit.fnl
View file

@ -1,6 +1,7 @@
(local GraphicsEditView (require :editor.gfxedit)) (local GraphicsEditView (require :editor.gfxedit))
(local style (require :core.style)) (local style (require :core.style))
(local tiles (require :game.tiles)) (local tiles (require :game.tiles))
(local files (require :game.files))
(local tiledraw (require :editor.tiledraw)) (local tiledraw (require :editor.tiledraw))
(local util (require :lib.util)) (local util (require :lib.util))
(local {: mouse-inside : activate : active? : checkbox : textfield} (util.require :editor.imstate)) (local {: mouse-inside : activate : active? : checkbox : textfield} (util.require :editor.imstate))
@ -20,7 +21,9 @@
(values ibyte ibit))) (values ibyte ibit)))
(fn TileView.tilesize [self] (values 16 16)) (fn TileView.tilesize [self] (values 16 16))
(fn TileView.tilekeys [self] [:gfx :neut]) (fn TileView.tilekeys [self]
(if files.game.tilesets (icollect [_ key (pairs files.game.tilesets)] key)
[:gfx]))
(fn get-byte [tile ibyte] (fn get-byte [tile ibyte]
(: (tile:sub (+ ibyte 1) (+ ibyte 1)) :byte)) (: (tile:sub (+ ibyte 1) (+ ibyte 1)) :byte))
@ -79,24 +82,26 @@
(when tile (when tile
(set tile.word (textfield self "Default word" tile.word x y 100 200)) (set tile.word (textfield self "Default word" tile.word x y 100 200))
(set tile.label (textfield self "Label" tile.label x (+ y pixel-size 4) 100 200))) (set tile.label (textfield self "Label" tile.label x (+ y pixel-size 4) 100 200)))
(each [iflag flagname (ipairs tiles.flags)] (each [iflag flagname (ipairs (tiles.flags))]
(self:draw-tile-flag flagname x (+ y (* (+ iflag 1) (+ pixel-size 4)))))) (self:draw-tile-flag flagname x (+ y (* (+ iflag 1) (+ pixel-size 4))))))
(fn TileView.update-tile [self newtile] (fn TileView.update-tile [self newtile]
(self.tilecache:update-tile self.itile newtile self.tilekey)) (self.tilecache:update-tile self.itile newtile self.tilekey))
(fn TileView.save [self] (tiles.savegfx (self:filename) self.tilecache.tiles))
(fn TileView.draw [self] (fn TileView.draw [self]
(self:draw_background style.background) (self:draw_background style.background)
(local (x y) (values (+ self.position.x 10) (+ self.position.y 10))) (self:draw_scrollbar)
(local (x y) (values (+ self.position.x style.padding.x (- self.scroll.x))
(+ self.position.y style.padding.y (- self.scroll.y))))
(local (editor-w editor-h) (self:draw-tile-editor (self:tile) x y)) (local (editor-w editor-h) (self:draw-tile-editor (self:tile) x y))
(self:draw-tile-flags (+ x editor-w pixel-size) y) (self:draw-tile-flags (+ x editor-w pixel-size) y)
(var selector-y (+ y editor-h pixel-size)) (var selector-y (+ y editor-h pixel-size))
(each [_ key (ipairs (self:tilekeys))] (each [_ key (ipairs (self:tilekeys))]
(local selector-h (self:draw-tile-selector x selector-y (- self.size.x 20) key)) (local selector-h (self:draw-tile-selector x selector-y (- self.size.x 20) key))
(set selector-y (+ selector-y selector-h pixel-size)))) (set selector-y (+ selector-y selector-h pixel-size)))
(set self.scrollheight (- selector-y y)))
(fn TileView.resource-key [self] :tiles)
(fn TileView.get_name [self] "Tile Editor") (fn TileView.get_name [self] "Tile Editor")
TileView TileView

91
game/files.fnl Normal file
View file

@ -0,0 +1,91 @@
(local util (require :lib.util))
(local lume (require :lib.lume))
(local tiledraw (require :editor.tiledraw))
(local files (util.hot-table ...))
(local default-filename "bitsy/game.json")
(local encoded-tile-fields [:gfx :mask])
(fn convert [tile field method]
(local oldval (. tile field))
(when oldval
(tset tile field (: oldval method)))
tile)
(fn convert-all [tile method root]
(let [encoded-tile-fields [:mask]]
(each [_ key (pairs (or root.tilesets {:tileset :gfx}))]
(table.insert encoded-tile-fields key))
(each [_ field (ipairs encoded-tile-fields)]
(convert tile field method))
tile))
(fn tile-deserialize [tile root]
(match (type tile)
:string {:gfx (tile:fromhex) :flags {}}
:table (convert-all tile :fromhex root)))
(fn tile-serialize [tile root] (convert-all (lume.clone tile) :tohex root))
(fn deserialize [key value root]
(match key
(where (or :tiles :portraits :font)) (tile-deserialize value root)
:levels (do (set value.map (value.map:fromhex)) value)
_ value))
(fn serialize [key value root]
(match key
(where (or :tiles :portraits :font)) (tile-serialize value root)
:levels (do (set value.map (value.map:tohex)) value)
_ value))
(fn clone [v]
(match (type v)
:table (lume.clone v)
_ v))
(fn filename [] (or files.filename default-filename))
(fn files.load [?filename]
(when ?filename (set files.filename ?filename))
(set files.game
(if (util.file-exists (filename))
(let [game (util.readjson (filename))]
(each [k v (pairs game)]
(tset game k (lume.map v #(deserialize k (clone $1) game))))
game)
{:tiles [] :portraits [] :font [] :levels []}))
files.game)
(fn files.save [?filename]
(when ?filename (set files.filename ?filename))
(let [game {}]
(each [k v (pairs files.game)]
(tset game k (lume.map v #(serialize k (clone $1) files.game))))
(util.writejson (filename) game)))
(fn new-cache [game key]
(let [spritegen (match key
:font tiledraw.char-to-sprite
:portraits tiledraw.portrait-to-sprite
_ tiledraw.tile-to-sprite)
gfx (. game key)]
(tiledraw.TileCache gfx spritegen)))
(fn files.cache [key]
(when (= (?. files :tilecaches key) nil)
(util.nested-tset files [:tilecaches key] (new-cache files.game key)))
(. files.tilecaches key))
(fn files.reload [?filename]
(files.load ?filename)
(when files.tilecaches
(each [key cache (pairs files.tilecaches)]
(cache:load (. files.game key)))))
(fn files.module []
(or files.game.module (: (filename) :match "^[^/]+")))
(when (= files.game nil)
(files.load))
files.hot

1
game/font.json
View file

@ -1 +0,0 @@
[{"flags":[],"gfx":"8080808080808080"},{"flags":[],"gfx":"8C8C8C8C88808C80"},{"flags":[],"gfx":"B3B3928080808080"},{"flags":[],"gfx":"B6FFB6B6B6FFB680"},{"flags":[],"gfx":"8CBE839EB09F8C80"},{"flags":[],"gfx":"80A3938884B2B180"},{"flags":[],"gfx":"8E9B9BCEBBB3EE80"},{"flags":[],"gfx":"8C8C888080808080"},{"flags":[],"gfx":"988C8C8C8C8C9880"},{"flags":[],"gfx":"8C98989898988C80"},{"flags":[],"gfx":"8CAD9E8C9EAD8C80"},{"flags":[],"gfx":"808C8CBF8C8C8080"},{"flags":[],"gfx":"808080808C8C8880"},{"flags":[],"gfx":"8080809C80808080"},{"flags":[],"gfx":"80808080808C8C80"},{"flags":[],"gfx":"80A0B0988C868280"},{"flags":[],"gfx":"9CB6B6BEB6B69C80"},{"flags":[],"gfx":"989C989898989880"},{"flags":[],"gfx":"9CB6B0988C86BE80"},{"flags":[],"gfx":"9CB6B098B0B69C80"},{"flags":[],"gfx":"9C9E9B9BBF989880"},{"flags":[],"gfx":"BE86869EB0B09E80"},{"flags":[],"gfx":"9C86869EB6B69C80"},{"flags":[],"gfx":"BEB0B0988C8C8C80"},{"flags":[],"gfx":"9CB6B69CB6B69C80"},{"flags":[],"gfx":"9CB6B6BCB0B09C80"},{"flags":[],"gfx":"808C8C808C8C8080"},{"flags":[],"gfx":"808C8C808C8C8880"},{"flags":[],"gfx":"B0988C868C98B080"},{"flags":[],"gfx":"8080BE80BE808080"},{"flags":[],"gfx":"868C98B0988C8680"},{"flags":[],"gfx":"9CB6B0988C808C80"},{"flags":[],"gfx":"9EB3B3BBBB839E80"},{"flags":[],"gfx":"9CB6B6B6BEB6B680"},{"flags":[],"gfx":"9EB6B69EB6B69E80"},{"flags":[],"gfx":"9CB6868686B69C80"},{"flags":[],"gfx":"9EB6B6B6B6B69E80"},{"flags":[],"gfx":"BE86869E8686BE80"},{"flags":[],"gfx":"BE86869E86868680"},{"flags":[],"gfx":"9EB383BBB3B39E80"},{"flags":[],"gfx":"B6B6B6BEB6B6B680"},{"flags":[],"gfx":"8C8C8C8C8C8C8C80"},{"flags":[],"gfx":"B0B0B0B0B6BE9C80"},{"flags":[],"gfx":"B6B69E9EB6B6B680"},{"flags":[],"gfx":"868686868686BE80"},{"flags":[],"gfx":"92BFBFBFB3B3B380"},{"flags":[],"gfx":"9EB6B6B6B6B6B680"},{"flags":[],"gfx":"9CB6B6B6B6B69C80"},{"flags":[],"gfx":"9EB6B69E86868680"},{"flags":[],"gfx":"9CB6B6B6BEB6BC80"},{"flags":[],"gfx":"9EB6B69EB6B6B680"},{"flags":[],"gfx":"9CB6869CB0B69C80"},{"flags":[],"gfx":"BFBF8C8C8C8C8C80"},{"flags":[],"gfx":"B6B6B6B6B6B69C80"},{"flags":[],"gfx":"B6B6B69C9C9C8880"},{"flags":[],"gfx":"B3B3B3BFBFBF9280"},{"flags":[],"gfx":"B6B6B69CB6B6B680"},{"flags":[],"gfx":"B6B6B6BCB0B09C80"},{"flags":[],"gfx":"BEBEB0988CBEBE80"},{"flags":[],"gfx":"BC8C8C8C8C8CBC80"},{"flags":[],"gfx":"8082868C98B0A080"},{"flags":[],"gfx":"9E98989898989E80"},{"flags":[],"gfx":"8894808080808080"},{"flags":[],"gfx":"808080808080BE80"}]

63
game/init.fnl
View file

@ -1,64 +1,5 @@
(local files (require :game.files))
(local util (require :lib.util)) (local util (require :lib.util))
(local {: lo : hi : readjson} util)
(local tile (util.reload :game.tiles))
(local {: prg : vm : org} (util.reload :game.defs))
(local disk (util.reload :game.disk)) (util.reload (files.module))
(util.reload :game.gfx)
(util.reload :game.footer)
(util.reload :game.map)
(util.reload :game.entity)
(util.reload :game.player)
(util.reload :game.boop)
(util.reload :game.cheat)
(tile.appendtiles org.code)
(org.code:append [:align 0x100] :font)
(tile.appendgfx org.code (tile.loadgfx tile.fn-font))
(tile.append-portraitwords vm {:pneut #[:vm :chuck-mode :get (vm:if [:lit :pchuck] [:lit :pneut])]})
(util.reload :game.level1)
(util.reload :game.level2)
(util.reload :game.level3)
(util.reload :game.level4)
(util.reload :game.level5)
(util.reload :game.level6)
(util.reload :game.bosskey)
(vm:var :tick-count)
(vm:word :handle-key :tick :read-key :dup :cheat-key :player-key :hide-footer)
(vm:word :tick :map-specific-tick :tick-count :get 1 :+ :tick-count :set :player-redraw :rnd :drop)
(vm:var :next-level 0)
(vm:word :load-next-level :next-level :get :dup (vm:if [:load-level 0 :next-level :set] [:drop]))
(vm:word :load-level ; level-ptr --
:lit :map-ptr :set :reload-level)
(vm:word :reload-level
:map-jaye-yx :jaye-yx :set
:map-neut-yx :neut-yx :set
:map-gord-yx :gord-yx :set
0 :gord-dir :set
0xffff :rexx-yx :set
:map-specific-load
:full-redraw)
(vm.code:append :main
[:jsr :reset]
[:jsr :interpret]
[:vm :hires
:lit :level1 :load-level
(vm:forever
(vm:hotswap-sync :lit :level6 :load-level)
:interactive-eval-checkpoint
:handle-key
)
:quit])
(disk.append-boot-loader prg)
(prg:assemble)
(disk.write prg)
prg

6
game/level2.fnl
View file

@ -1,6 +0,0 @@
(local {: deflevel : say : itile} (require :game.defs))
(local {: ev} (require :game.entity))
(local level (deflevel "game/map2.json" :level2))
(local vm level.vm)
level

1
game/map1.json
View file

@ -1 +0,0 @@
{"loadword":"earthquake","map":"212121214121212121212121212141212121212161026161610261616102616161616102616161216143C0C0C2C0C0C0C0C0C0C081C0C0C0C0C0612161C0C08282C0C0C082C0C0C061C0C0C0C0C2024161C0C0C0C0C0C0C0C0C2C082C182C0C0E082612161C2C08282C0C0C0C082C0C061616161616161216161616161C16181616161616143C0C0C282612161C0C0C0C0C0C0C0C0C0C0C061C0C0C0C0C0022161E0828282C0C0C0C0C2C0C081C0C0C0C003612161C2C2C2C0C0C0C0C0C0C0C061C0C0C0C0C06141610303C043C2C0C0C0C0C0C061C0C0C003C061216161616161616161228161616161616161610221","jaye":{"y":9,"x":15},"tickword":"","moveword":"","objects":[{"x":8,"func":"door","linkword":"","name":"","y":6},{"x":2,"func":"firstterm","y":4,"name":"","linkword":"","link":3},{"x":17,"func":"neutterm","y":8,"name":"","linkword":"","link":2},{"x":13,"func":"switch","y":8,"name":"","linkword":"","link":8},{"link":6,"x":9,"y":1,"linkword":"","name":"","func":"exitscanner"},{"x":10,"linkentity":"level2","func":"exitdoor","y":1,"name":"","linkword":"exitlevel"},{"link":1,"x":6,"y":6,"linkword":"","name":"","func":"switch"},{"x":13,"func":"firstdoor","name":"","linkword":"","y":10}]}

1
game/map2.json
View file

@ -1 +0,0 @@
{"neut":{"y":12,"x":10},"map":"616161616161626161618161616161616161612161C0C0C06361C0C0E0C0C0C0C0C06103C0C0022161E0C0C0C081C0C0C0C0C0C0C0C081C0C0E0614161C0C0C0C06143C0C0C0C0C0C04322C0C0C0222161C0C0C0C061618161616161816161C0C0C00221616181616161C0C0C06143C0C0C061618161612161C0C0C06361E0C0C061C0C0C0C0C1E0C003612122C0C0C0C061C0C0C061C0E0C0C061C0C0C0022161C0C0C0C061616161616261616161C0C0C061416101C0C0C081C0C0E061C0C0E0C081C0C0C0022162C0C0C02361E0C0C06143C0C0C061E2A2E061216161C1616261612281616122226162C1C1616121","loadword":"","jaye":{"y":11,"x":11},"tickword":"","moveword":"","objects":[{"x":9,"link":2,"func":"term","linkword":"","name":"","y":11},{"x":2,"link":6,"func":"term","linkword":"","name":"","y":3},{"x":6,"func":"door","linkword":"","name":"","y":10},{"x":1,"link":5,"func":"scan","linkword":"","name":"","y":5},{"x":8,"func":"door","linkword":"","name":"","y":8},{"x":7,"link":2,"func":"term","linkword":"","name":"","y":6},{"x":12,"link":8,"func":"scan","linkword":"","name":"","y":1},{"x":17,"func":"door","linkword":"","name":"","y":7},{"x":13,"link":10,"func":"scan","linkword":"","name":"","y":1},{"x":13,"func":"door","linkword":"","name":"","y":8},{"x":15,"link":12,"func":"switch","linkword":"","name":"","y":6},{"x":2,"link":13,"func":"term","linkword":"","name":"","y":10},{"x":12,"link":12,"func":"term","linkword":"","name":"","y":5},{"x":15,"link":15,"func":"scan","linkword":"","name":"","y":9},{"x":15,"func":"door","linkword":"","name":"","y":10},{"x":16,"link":17,"func":"term","linkword":"","name":"","y":6},{"x":18,"link":16,"func":"term","linkword":"","name":"","y":10},{"x":15,"func":"door","linkword":"","name":"","y":3},{"x":19,"link":18,"func":"scan","linkword":"","name":"","y":9},{"x":13,"link":21,"func":"term","linkword":"","name":"","y":3},{"x":18,"link":20,"func":"term","linkword":"","name":"","y":2},{"x":8,"link":23,"func":"scan","linkword":"","name":"","y":1},{"x":9,"linkentity":"level3","func":"exitdoor","linkword":"exitlevel","name":"","y":1},{"x":16,"link":3,"func":"switch","linkword":"","name":"","y":1},{"x":3,"link":26,"func":"switch","linkword":"","name":"","y":1},{"x":6,"func":"door","linkword":"","name":"","y":3},{"x":9,"link":28,"func":"term","linkword":"","name":"","y":3},{"x":7,"link":27,"func":"term","linkword":"","name":"","y":2},{"x":3,"func":"door","linkword":"","name":"","y":7},{"x":17,"link":29,"func":"switch","linkword":"","name":"","y":1}]}

1
game/map3.json
View file

@ -1 +0,0 @@
{"neut":{"y":12,"x":8},"map":"616161616161616181616161616161616161612161C063C0C0C0C0C0C0C06143C0E0C2C0C043022161C0C0C0C0C0C0C0C0C022C0C0C0C0C0C0C0614161C0C0C2C0C0C0C0C0C081C0C0C0C0C0C0C0612161C08282A2C0C0C0C0436123C0C0C0C0C0030221616161616161616261616161618161616161612161C063C0C02301C3C163C0C0C0C0C0822363022122C0C0C0C0C0C0A2A1C0C0C0C0C0C0C2C0C0614181C0C0C0C0E2C0C061C0C0C0C0C0C0C0C2C061216123C0C0C0C083C061E0C2C0C0C0C0438203022161610261610261616161026161026161026161212121212141212121212121212121412121212121","loadword":"level3-load","jaye":{"y":11,"x":9},"tickword":"","moveword":"","objects":[{"link":2,"x":1,"y":5,"linkword":"","name":"","func":"scan"},{"x":1,"linkentity":"level4","func":"exitdoor","name":"","linkword":"exitlevel","y":4},{"link":4,"x":7,"y":6,"linkword":"","name":"","func":"gordterm"},{"link":7,"x":14,"y":11,"linkword":"","name":"","func":"term"},{"link":6,"x":9,"y":6,"linkword":"","name":"gordswitch","func":"switch"},{"x":11,"func":"door","name":"","linkword":"","y":9},{"link":3,"x":10,"y":3,"linkword":"","name":"","func":"term"},{"link":9,"x":11,"y":10,"linkword":"","name":"","func":"scan"},{"x":14,"func":"door","name":"","linkword":"","y":7},{"x":7,"func":"meetrexx","y":3,"name":"","linkword":""},{"x":8,"func":"meetgord","y":6,"name":"","linkword":""},{"x":8,"func":"gordtable","y":5,"linkword":"","name":""}]}

1
game/map4.json
View file

@ -1 +0,0 @@
{"neut":{"y":5,"x":20},"map":"61616161616161616261616161616161616161616143C0C0C082E082C0C0636163C0C083C0C0436161C0C0C0C0C0C2C0C0C0C061C0C0C0C0C0C0C06161C0C0C0C0C0C0C0C0C0C061C0C0C0C0C0C0C2616103C0C0A3C0C0C003C0C06163C0C0C0C082A2616161616161C1C1C16161812261618161616161616143C0C0C0C0C0C04361C0C0C0C0C0C0C0C0636181C0C0C0C0C0C0C0C081C0C0C0C0C0C0C0C0C06122C0C0C0C0C0E2C0C0C1A2E2C0C0C0C0C0C0C08161E082828282E0C02361A2C0C0C0C0C0C003236161026161610222616102616161610261616102612121214121212121212121212121412121212121","loadword":"","gord-following":true,"jaye":{"y":4,"x":19},"tickword":"","moveword":"","objects":[{"x":7,"func":"term","y":11,"linkword":"term-dual-link","name":""},{"link":1,"y":3,"func":"term","name":"term-exit","linkword":"","x":2},{"link":1,"y":3,"func":"term","name":"term-scan","linkword":"","x":7},{"x":11,"func":"door","y":7,"linkword":"","name":""},{"link":4,"y":7,"func":"scan","name":"","linkword":"","x":12},{"x":15,"func":"door","y":7,"linkword":"","name":""},{"link":3,"y":7,"func":"switch","name":"","linkword":"","x":7},{"x":10,"func":"door","y":5,"linkword":"","name":""},{"link":4,"y":4,"func":"switch","name":"","linkword":"","x":10},{"x":16,"func":"rexx","y":11,"linkword":"","name":""},{"link":8,"y":2,"func":"scan","name":"","linkword":"","x":7},{"link":13,"y":4,"func":"scan","name":"","linkword":"","x":1},{"x":1,"linkentity":"level5","func":"exitdoor","y":5,"linkword":"exitlevel","name":""},{"x":5,"func":"rexx","y":8,"linkword":"","name":""},{"x":7,"func":"tutorial-chair","linkword":"","name":"","y":10},{"link":6,"x":8,"y":7,"linkword":"","name":"","func":"switch"},{"link":2,"x":6,"y":7,"linkword":"","name":"","func":"switch"}]}

1
game/map5.json
View file

@ -1 +0,0 @@
{"neut":{"y":6,"x":20},"map":"21616161228161616161616161616161616162612102E0C0C0C0C0E0C04361C0C0C0C0C0A3C0C0612161C0C0C0C0C0C0C0C022C0C0C08282C0828261416103C0C0C0C0C0C0C081C0C0C0C0C0C0C0C2C1210203C0C0C0C0C0C04361C0C0C08282838282622161616161816161616161618161616161616161216163C0C0C0C0E0C0C06143C0C0C0C0C0C063612102C0C0C0C0C0C0C0C061C0C0C0C0C0C0C0C0814161C0C0C0C0E2C0E2836101C0C0C0C0C0C0C0C1216143C0C0C082A2A2A281C0C0C043034382E26121610261610261C16102616161026161610261612121212121214121212121212121214121212121","loadword":"","tickword":"doortimer-tick","jaye":{"y":5,"x":19},"gord-following":true,"moveword":"move-garbagerexx","objects":[{"x":17,"func":"garbagerexx","name":"south-rexx","linkword":"","y":11},{"x":17,"func":"garbagerexx","name":"","linkword":"","y":8},{"link":13,"x":20,"y":9,"linkword":"","name":"timedswitch","func":"do-timedswitch"},{"link":16,"x":20,"y":4,"linkword":"","name":"","func":"switch"},{"link":9,"x":12,"y":4,"linkword":"","name":"","func":"term"},{"x":10,"func":"healthyrexx","name":"","linkword":"","y":4},{"link":17,"x":8,"y":2,"linkword":"","name":"","func":"switch"},{"link":10,"x":8,"y":6,"linkword":"","name":"","func":"term"},{"link":5,"x":8,"y":11,"linkword":"","name":"","func":"term"},{"link":8,"x":3,"y":11,"linkword":"","name":"","func":"term"},{"link":12,"x":5,"y":12,"linkword":"","name":"","func":"scan"},{"x":6,"linkentity":"level6","func":"exitdoor","name":"","linkword":"exitlevel","y":12},{"x":6,"func":"door","name":"","linkword":"","y":7},{"x":11,"func":"explodingdoor","name":"","linkword":"","y":9},{"link":14,"x":11,"y":10,"linkword":"","name":"","func":"scan"},{"x":13,"func":"door","name":"","linkword":"","y":7},{"x":11,"func":"door","name":"","linkword":"","y":3}]}

1
game/map6.json
View file

@ -1 +0,0 @@
{"neut":{"y":1,"x":5},"map":"210261616161616161616161812261616161E1614161C2C081C0C0C0C0C0C0C0C0C0E0C081C0C0622161E04384C0C0C043C0C0C043C0C0C0848201612102616161C0C061610281026161C0C0616161612161C2C0C0C0C061E2C0C0C0A261C0C0C0C0E2612161E003C0C0C061C0C0C0C08261C0C0C003E06121026161C0C0C061E08282E2E061C0C0C06161612161C2C0C0C0C06103C0C0C02361C0C0C0C0C2614161E003C0C0C0616102C1026161C0C0C003E06121026184C0C0C0C043C043C063C0C0C0846161612161E081C0C0C0C0C0C0C0C0C0C0C0C081C083612161612261816161616161616161616161616161","loadword":"","tickword":"","jaye":{"y":2,"x":6},"gord-following":true,"moveword":"","objects":[{"x":3,"func":"c4","y":10,"name":"","linkword":"linkloop","link":6},{"x":5,"func":"keypad2","y":10,"name":"","linkword":"","link":3},{"x":5,"func":"door","y":11,"name":"","linkword":""},{"x":11,"func":"door","y":9,"name":"","linkword":""},{"x":13,"func":"c9","y":6,"name":"","linkword":"linkloop","link":17},{"x":9,"func":"c8","y":6,"name":"","linkword":"linkloop","link":5},{"link":23,"y":4,"func":"switch","linkword":"","name":"","x":11},{"x":3,"func":"c3","y":7,"name":"","linkword":"linkloop","link":1},{"x":3,"func":"c2","y":4,"name":"","linkword":"linkloop","link":8},{"x":3,"func":"c1","y":2,"name":"","linkword":"linkloop","link":23},{"x":4,"func":"door","y":2,"name":"","linkword":""},{"x":4,"func":"keypad1","y":3,"name":"","linkword":"","link":11},{"x":4,"func":"scan","y":1,"name":"","linkword":"","link":4},{"x":17,"func":"door","y":2,"name":"","linkword":""},{"x":17,"func":"keypad3","y":3,"name":"","linkword":"","link":14},{"x":19,"func":"rexx","y":2,"name":"","linkword":""},{"x":19,"func":"c5","y":4,"name":"","linkword":"linkloop","link":18},{"x":19,"func":"c6","y":7,"name":"","linkword":"linkloop","link":19},{"x":19,"func":"c7","y":10,"name":"firewall","linkword":"linkloop","link":10},{"x":19,"func":"switch","y":12,"name":"","linkword":"","link":19},{"x":17,"func":"keypad4","y":10,"name":"","linkword":"","link":22},{"x":17,"func":"door","y":11,"name":"","linkword":""},{"x":15,"func":"cx","y":11,"name":"","linkword":"linkloop","link":9},{"x":14,"func":"scan","y":12,"name":"","linkword":"","link":25},{"x":13,"linkentity":"","func":"exitdoor","y":12,"name":"","linkword":"endgame"}]}

1
game/portraits.json
View file

@ -1 +0,0 @@
[{"gfx":"8080808080E0E0F0F8FC2CBCACACACAC80809CFEFFFFFFD7D5D5555D4F5DD5D5BCB8B8B8F8F8F8F8FCFCFEFE86D0D0D495D5D5E5D5D5D5D7C797D7D0AAAAAAAA808086BFFFFFFFFAEAAA2A2E3C2EAAAA80808080808183878787058F8D8D8D8FAAAAAAA7AAAAEAEAE2E8EA8AD5D5D5D58F8F8787878F8F8F9F9FBFBE808A8AAA","label":"pjaye","flags":[]},{"gfx":"00002020000000004808080800202028004040011404450144010805445420352020000808084800000000202000000020544405080144014504140140400000000202012921220122011021222A052D00000405000001011211101100040415052A222110012201222129010202000004040011101112010100000504000000","label":"pneut","flags":[]},{"gfx":"80C090808484848484848484A8A8A8A8AA8080808080D4D4D5D5F59DFDD5D5D5A8A08080808080808080808080E0F8FC95D5D5D5F595D5D4D084D4D4D4D7FFFFD58080808080AAAAAAAABAE2FAAAAAA280828880A0A0A0A1A1A1A1A195959595A0AAAAAAAFA8AAAA8AA0AAAAAAEAFFFF95858181818181808080808080879FBF","label":"pgord","flags":[]},{"gfx":"808080808080C0C0C0C0C0C0C0C0C0C0808080808080AAAAFAFAFAAAAAAAAAAA8080808080C0D0D0D0D0D0D0D0D0D0D0A0A0A0A0A0AAAAAAA8A8A8A8A8A8A8A8808080808080D5D5DFDFDFD5D5D5D5D5808080808080828282828282828282828585858585D5D5D595959595959595958080808080828A8A8A8A8A8A8A8A8A8A","label":"prexx","flags":[]},{"gfx":"808080F8F8F8F8F8F8B8B8F8F8B8B8F8808080FFFFFFFFDFDFFDFDDFDFFDFDDFF8B8B8F8F8B8B8F8F8F8F8F8F8D0D080DFFDFDDFDFFDFDDFDFFFFFFFFFAAAA80808080FFFFFFFFFEFEAFAFFEFEAFAFFE8080808FAFAFAFAFAFAFAFAFAFAFAFAFFEAFAFFEFEAFAFFEFEFFFFFFFFD5D580AFAFAFAFAFAFAFAFAFAFAFAFAFAAAA80","label":"ppady","flags":[]},{"gfx":"0080C07070303030303030303030303000AAAA7F0045001400150051005400003030707000703018187C4C7E000000000000007F007F0000007F017F0000000000D5D57F400A0028000A002000080000008A8A8B8B8B8B8B8B8B8B8B8B8B8B8B0000407F007F6030301F187F000000008B8B8B03000F0C060603030100000000","label":"pterm","flags":[]},{"gfx":"80808080808080A0C0A0C0A0808088AA8080808080808185AA858285C1D0A0D0D4AA94AA94AA888080A0C0A0C0A08080AAD2A2D2A2D2A2D2C185AA858285818080A0A8D0A8A09090D581A1C1A0C2A1C280808180818080808081858285828582A1828182959291929090D5808080808085818080808084958A958A958A958480","label":"plibb","flags":[]},{"gfx":"808080808080808088A082A8A0AAA8AA849494D4D4D4D0D5D4D1D5D58595D5D5AAAA8AAA8AAA82AA828A808280808080D4D5D4D5D4D5D4D4D4D4D0C0C0C080808080808080A288A2A08AA2AAAAAAAAAA84949495958585808181848184848581AAAAAA8AAA8AAA8AAAAAA8A2A2AAAA8080818181818181818585818185818080","label":"pchuck","flags":[]}]

63
game/tiles.fnl
View file

@ -1,62 +1,37 @@
(local util (require :lib.util)) (local util (require :lib.util))
(local lume (require :lib.lume)) (local lume (require :lib.lume))
(local files (require :game.files))
(local flags [:walkable :neutable :debris :sittable]) (fn flags [] (or files.game.tileflags [:walkable]))
(local flag-to-bit {}) (fn flag-to-bit []
(each [iflag flag (ipairs flags)] (collect [iflag flag (ipairs (flags))] (values flag (bit.lshift 1 (- iflag 1)))))
(tset flag-to-bit flag (bit.lshift 1 (- iflag 1))))
(local encoded-tile-fields [:gfx :neut :mask]) (fn appendgfx [org gfx ?key ?label-prefix]
(fn convert [tile field method]
(local oldval (. tile field))
(when oldval
(tset tile field (: oldval method)))
tile)
(fn convert-all [tile method]
(each [_ field (ipairs encoded-tile-fields)]
(convert tile field method))
tile)
(fn deserialize [tile]
(match (type tile)
:string {:gfx (tile:fromhex) :flags {}}
:table (convert-all tile :fromhex)))
(fn serialize [tile] (convert-all (lume.clone tile) :tohex))
(local fn-tiles "game/tiles.json")
(local fn-portraits "game/portraits.json")
(local fn-font "game/font.json")
(fn loadgfx [filename] (lume.map (util.readjson filename) deserialize))
(fn savegfx [filename gfx] (util.writejson filename (lume.map gfx serialize)))
(fn appendgfx [org gfx ?key ?ignore-labels]
(each [_ g (ipairs gfx)] (each [_ g (ipairs gfx)]
(when (and g.label (not ?ignore-labels)) (org:append g.label)) (when g.label (org:append (.. (or ?label-prefix "") g.label)))
(org:append [:bytes (. g (or ?key :gfx))]))) (org:append [:bytes (. g (or ?key :gfx))])))
(fn appendtiles [org] (fn appendtiles [org]
(local tiles (loadgfx fn-tiles)) (local tiles files.game.tiles)
(org:append [:align 0x100] :jaye-tileset) (local flag-lookup (flag-to-bit))
(appendgfx org tiles) (each [tileset key (pairs (or files.game.tilesets {:tileset :gfx}))]
(org:append [:align 0x100] :neut-tileset) (org:append [:align 0x100] tileset)
(appendgfx org tiles :neut true) (appendgfx org tiles key (if (= key :gfx) nil (.. key :-))))
(appendgfx org (loadgfx fn-portraits)) (appendgfx org files.game.portraits nil :portrait-)
(org:append :tileflags) (org:append :tileflags)
(each [_ tile (ipairs tiles)] (each [_ tile (ipairs tiles)]
(var flags 0) (var flags 0)
(each [flag _ (pairs tile.flags)] (each [flag _ (pairs tile.flags)]
(set flags (bit.bor flags (. flag-to-bit flag)))) (set flags (bit.bor flags (. flag-lookup flag))))
(org:append [:db flags]))) (org:append [:db flags])))
(fn append-portraitwords [vm ?overrides] (fn append-portraitwords [vm ?overrides]
(local overrides (or ?overrides {})) (local overrides (or ?overrides {}))
(each [_ p (ipairs (loadgfx fn-portraits))] (each [_ p (ipairs files.game.portraits)]
(let [wordname (.. :draw- p.label) (let [wordname (.. :draw-portrait- p.label)
override (. overrides p.label)] override (. overrides p.label)]
(vm:word (.. :draw- p.label) :show-footer (vm:word wordname :show-footer
(if override (override p.label) [:vm :lit p.label]) (if override (override p.label) [:vm :lit (.. :portrait- p.label)])
:draw-portrait)))) :draw-portrait))))
(fn encode-yx [xy] (fn encode-yx [xy]
@ -79,6 +54,6 @@
(if (= tile.label label) (encode-itile itile) (if (= tile.label label) (encode-itile itile)
(find-itile tiles label (+ itile 1)))) (find-itile tiles label (+ itile 1))))
{: loadgfx : savegfx : appendtiles : appendgfx : append-portraitwords : flags : flag-to-bit : find-itile {: appendtiles : appendgfx : append-portraitwords : flags : flag-to-bit : find-itile
: fn-tiles : fn-portraits : fn-font : encode-yx : encode-itile : decode-itile} : encode-yx : encode-itile : decode-itile}

1
game/tiles.json
View file

File diff suppressed because one or more lines are too long

68
inspector/init.fnl Normal file
View file

@ -0,0 +1,68 @@
(local util (require :lib.util))
(local style (require :core.style))
(local {: defmulti : defmethod} (util.require :lib.multimethod))
(local {: textbutton} (util.require :editor.imstate))
(local inspector (util.hot-table ...))
(fn inspector.best-inspector [v]
(var best-inspector nil)
(var best-priority -1)
(each [inspector {: priority : predicate} (pairs inspector.inspectors)]
(when (and (> priority best-priority) (predicate v))
(set best-inspector inspector)
(set best-priority priority)))
best-inspector)
(set inspector.inspect
(defmulti (fn [state value view x y w]
(when (= state.inspector nil)
(set state.inspector (inspector.best-inspector value)))
state.inspector) :inspect ...))
(fn inspector.register [name priority predicate inspect-func]
(when (= inspector.inspectors nil)
(set inspector.inspectors {}))
(tset inspector.inspectors name {: predicate : priority :inspector inspect-func})
(defmethod inspector.inspect name inspect-func))
(fn inspector.text-height [text ?font]
(let [font (or ?font style.code_font)
(_ newlines) (text:gsub "\n" "\n")]
(* (font:get_height) (+ newlines 1))))
(fn inspector.draw-text [font text x y color]
(renderer.draw_text font text x y color)
(inspector.text-height text))
(inspector.register :default 0 #true (fn [state value view x y w]
(inspector.draw-text style.code_font (fv value) x y style.text)))
(inspector.register :table 10
#(and (= (type $1) :table) (not= (next $1) nil))
(fn [state tbl view x y w]
(local font style.code_font)
(var h 0)
; todo: state assumes an .inspector key
; todo: inspector swapping
; todo: edit in place?
(fn get-kstate [tbl k state]
(when (= nil state.keys) (set state.keys {}))
(when (= nil (?. state.keys k))
(util.nested-tset state [:keys k] {:collapsed (= (type (. tbl k)) :table) :children {}}))
(. state.keys k))
(each [k v (pairs tbl)]
(let [kstate (get-kstate tbl k state)
kstr (fv k)
wk (font:get_width kstr)
xoffset (+ wk style.padding.x)
toggle-collapse (textbutton view kstr x (+ y h))
hv (if kstate.collapsed
(inspector.draw-text font "..." (+ x xoffset) (+ y h) style.syntax.comment)
(inspector.inspect kstate.children v view (+ x xoffset) (+ y h) (- w xoffset)))]
(when toggle-collapse (set kstate.collapsed (not kstate.collapsed)))
(set h (+ h hv style.padding.y))))
h))
inspector.hot

66
kfest2021.md Normal file
View file

@ -0,0 +1,66 @@
# Honeylisp
## Introduction
* 286 project
* Honeylisp vision
## Assembler
### What is an assembler?
* I _thought_ the hard part was going to be converting mnemonics to bytes
* Turns out the hard part is actually converting labels to bytes
* zero-page instructions are a different size!
### How it works
* Represent each opcode as a Fennel data literal
* nest blocks arbitrarily - "lexical scope"
* multi-pass
## VM
* Forth-ish stack machine
* "direct threaded" inner interpreter
* extend assembler with :vm directive
* "immediate words" are just Fennel functions
## Lite
* Minimal extensible text editor built in Lua
* love2d port
## Custom Editors
* imgui style
* show tile editor with map editor
* font + portrait editors based on tile editor
* generate bytes / code with fennel functions! (maps, gfx, etc)
## MAME Upload
* Nod to Dagen Brock's 2016 KFest talk on GSPlus https://www.youtube.com/watch?v=1LzCmpAanpE
* Integrated Jeejah networked REPL into MAME
* Can send arbitrary Fennel code to MAME to control it
* Poke blocks of memory over the network (nREPL uses bencode from bittorrent, which allows this to be fairly low overhead)
## Live Code Injection
* The assembled program is an object in memory, which we can extend interactively
* We can write new code and poke it into memory while the old code is running!
* Game code is a loop - we can have a "sync point" at the top of the loop where the state of the game is well-known
* (demo switching video modes, printing debug output, making sounds)
## Hot Reload
* Because the assembled program is an object in memory
## Tape generation
* Benefit of building tools in a game engine - I can just output audio
* Extended assembler to accept BASIC tokens and generate linked list of BASIC lines, so the whole thing could be bootstrapped
## Disk generation
* Take a ProDOS disk image, parse it, and add files to it
* Generate loader program, rest of game can be loaded as an overlay
* New disk image is generated on every build because why not? It's fast
## Neu] [ower
* Fun tricks: Random number generator (never used for gameplay purposes) = just dump a couple dozen random bytes
## 8-Bitsy
* Full "code-optional" environment
* Kind of awkward to actually use, but it works!
* Son drew some art
* Improvisational game design!

957
lib/fennel.lua
View file

File diff suppressed because it is too large Load diff

4
lib/lume.lua
View file

@ -624,7 +624,7 @@ function lume.wordwrap(str, limit)
check = limit check = limit
end end
local rtn = {} local rtn = {}
local line = "" local line = str:match("^(%s*)")
for word, spaces in str:gmatch("(%S+)(%s*)") do for word, spaces in str:gmatch("(%S+)(%s*)") do
local s = line .. word local s = line .. word
if check(s) then if check(s) then
@ -694,7 +694,7 @@ function lume.hotswap(modname)
local oldmt, newmt = getmetatable(old), getmetatable(new) local oldmt, newmt = getmetatable(old), getmetatable(new)
if oldmt and newmt then update(oldmt, newmt) end if oldmt and newmt then update(oldmt, newmt) end
for k, v in pairs(new) do for k, v in pairs(new) do
if type(v) == "table" then update(old[k], v) else old[k] = v end if type(v) == "table" and type(old[k]) == "table" then update(old[k], v) else old[k] = v end
end end
end end
local err = nil local err = nil

18
lib/multimethod.fnl Normal file
View file

@ -0,0 +1,18 @@
(local util (require :lib.util))
(local mm {})
(fn mm.__call [{: module : name} ...]
(let [dispatcher (. mm.dispatchers module name)
key (dispatcher ...)
method (or (. mm.methods module name key) (. mm.methods module name :default))]
(method ...)))
(fn mm.defmulti [dispatcher name module]
(util.nested-tset mm [:dispatchers module name] dispatcher)
(setmetatable {: module : name} mm))
(fn mm.defmethod [{: module : name} key method]
(util.nested-tset mm [:methods module name key] method))
mm

39
lib/util.fnl
View file

@ -53,6 +53,16 @@
(fn swappable-require [modname] (fn swappable-require [modname]
(swappable (require modname))) (swappable (require modname)))
(fn hot-table [modname]
(local tbl {})
(fn find-table []
(let [loaded-pkg (. package.loaded modname)]
(if (= (type loaded-pkg) :table) loaded-pkg tbl)))
(setmetatable {:hot tbl} {
:__index (fn [_ key] (. (find-table) key))
:__newindex (fn [_ key val] (tset (find-table) key val))
}))
(fn readjson [filename] (fn readjson [filename]
(local f (io.open filename :r)) (local f (io.open filename :r))
(local text (f:read "*a")) (local text (f:read "*a"))
@ -76,8 +86,33 @@
(fn in-coro [f ...] (-> (coroutine.create f) (coroutine.resume ...))) (fn in-coro [f ...] (-> (coroutine.create f) (coroutine.resume ...)))
(fn multival-next [multival i]
(when (< i multival.n)
(values (+ i 1) (. multival (+ i 1)))))
(fn multival-ipairs [multival]
(values multival-next multival 0))
(fn multival [...]
(local multival {:n (select :# ...) :ipairs multival-ipairs})
(for [i 1 multival.n]
(tset multival i (select i ...)))
multival)
(fn nested-tset [t keys value]
(let [next-key (. keys 1)]
(if (= (length keys) 1) (tset t next-key value)
(do (when (= (. t next-key) nil)
(tset t next-key {}))
(nested-tset (. t next-key) (lume.slice keys 2) value)))))
(fn file-exists [name]
(let [f (io.open name :r)]
(when (not= f nil) (io.close f))
(not= f nil)))
{: int8-to-bytes : int16-to-bytes : int24-to-bytes : bytes-to-uint8 : bytes-to-uint16 : bytes-to-uint24 {: int8-to-bytes : int16-to-bytes : int24-to-bytes : bytes-to-uint8 : bytes-to-uint16 : bytes-to-uint24
: splice : lo : hi : splice : lo : hi
: reload : hotswap : swappable :require swappable-require : reload : hotswap : swappable :require swappable-require : hot-table : nested-tset
: readjson : writejson : waitfor : in-coro} : readjson : writejson : file-exists : waitfor : in-coro : multival}

56
link/mame.fnl
View file

@ -23,7 +23,7 @@
(set self.breakpoints {})) (set self.breakpoints {}))
(fn Machine.boot [self] (fn Machine.boot [self]
(when (not self.pid) (when (not self.pid)
(set self.pid (start-mame :apple2p)))) (set self.pid (start-mame :apple2e))))
(fn Machine.run [self] (fn Machine.run [self]
(self:boot) (self:boot)
(self:connect)) (self:connect))
@ -87,6 +87,37 @@
(when self.monitor (self.monitor:shutdown-session)) (when self.monitor (self.monitor:shutdown-session))
(when (nrepl:connected?) (nrepl:disconnect)) (when (nrepl:connected?) (nrepl:disconnect))
(set self.breakpoints {})) (set self.breakpoints {}))
(fn Machine.read [self addr len]
(var bytes nil)
(self:coro-eval
"(let [bencode (require :bencode)
{: addr : len} (bencode.decode (io.read))
mem (. manager.machine.devices ::maincpu :spaces :program)]
(var bytes \"\")
(for [i 1 len]
(set bytes (.. bytes (string.char (mem:read_u8 (+ addr i -1))))))
(io.write bytes))"
(lume.merge
(self:input-handler (bencode.encode {: addr : len}))
{:out #(set bytes $2)}))
bytes)
(fn Machine.read-batch [self addr-to-len]
(var addr-to-bytes nil)
(self:coro-eval
"(let [bencode (require :bencode)
addr-to-len (bencode.decode (io.read))
mem (. manager.machine.devices ::maincpu :spaces :program)
addr-to-bytes {}]
(each [addr len (pairs addr-to-len)]
(var bytes \"\")
(for [i 1 len]
(set bytes (.. bytes (string.char (mem:read_u8 (+ addr i -1))))))
(tset addr-to-bytes addr bytes))
(io.write (bencode.encode addr-to-bytes)))"
(lume.merge
(self:input-handler (bencode.encode addr-to-len))
{:out #(set addr-to-bytes (bencode.decode $2))}))
addr-to-bytes)
(fn Machine.write [self addr bytes] (fn Machine.write [self addr bytes]
(if (> (bytes:len) 0x1000) (if (> (bytes:len) 0x1000)
(do (self:write addr (bytes:sub 1 0x1000)) (do (self:write addr (bytes:sub 1 0x1000))
@ -99,15 +130,26 @@
(for [i 1 (bytes:len)] (for [i 1 (bytes:len)]
(mem:write_u8 (+ addr i -1) (string.byte (bytes:sub i i)))))" (mem:write_u8 (+ addr i -1) (string.byte (bytes:sub i i)))))"
(bencode.encode {: addr : bytes})))) (bencode.encode {: addr : bytes}))))
(fn Machine.write-batch [self addr-to-bytes]
(self:eval-input
"(let [bencode (require :bencode)
addr-to-bytes (bencode.decode (io.read))
mem (. manager.machine.devices ::maincpu :spaces :program)]
(each [addr bytes (pairs addr-to-bytes)]
(for [i 1 (bytes:len)]
(mem:write_u8 (+ addr i -1) (string.byte (bytes:sub i i))))))"
(bencode.encode addr-to-bytes)))
(fn Machine.launch [self prg] (fn Machine.launch [self prg]
(self:eval "(manager.machine:soft_reset)") (self:eval "(manager.machine:soft_reset)")
(self:eval (string.format "(emu.keypost \"CALL-151\\n %xG\\n\")" (prg:lookup-addr prg.start-symbol)))) (self:eval (string.format "(emu.keypost \"CALL-151\\n %xG\\n\")" (prg:lookup-addr prg.start-symbol))))
(fn Machine.reboot [self] (self:eval "(manager.machine:hard_reset)")) (fn Machine.reboot [self] (self:eval "(manager.machine:hard_reset)"))
(fn Machine.coro-eval [self code] (fn Machine.coro-eval [self code ?handlers]
(var result nil) (var result nil)
(local append-to-result #(set result (.. (or result "") $2))) (local append-to-result #(set result (.. (or result "") $2)))
(self:eval code (self:eval code
(self:coro-handlers (coroutine.running) {:value append-to-result :out append-to-result})) (self:coro-handlers (coroutine.running)
(lume.merge {:value append-to-result :out append-to-result}
(or ?handlers {}))))
(coroutine.yield) (coroutine.yield)
(or result "<no result>")) (or result "<no result>"))
(fn Machine.dbgcmd [self cmd ?handlers] (fn Machine.dbgcmd [self cmd ?handlers]
@ -130,10 +172,14 @@
(fn Machine.hotswap [self prg-old prg-new] (fn Machine.hotswap [self prg-old prg-new]
(local addr (prg-old:lookup-addr :debug-stub)) (local addr (prg-old:lookup-addr :debug-stub))
(self:set-bp addr (self:set-bp addr
(fn [] (self:clear-bp addr) #(util.in-coro (fn []
(self:clear-bp addr)
(local hotswap (prg-old:read-hotswap self))
(prg-new:upload self) (prg-new:upload self)
(prg-new:write-hotswap self hotswap)
(self:jump (prg-new:lookup-addr :on-hotswap)) (self:jump (prg-new:lookup-addr :on-hotswap))
(self:continue)))) (self:continue)))))
(fn Machine.overlay [self prg-overlay] (fn Machine.overlay [self prg-overlay]
(self:step) (self:step)
(prg-overlay:upload self) (prg-overlay:upload self)

8
link/nrepl-session.fnl
View file

@ -19,7 +19,7 @@
(fn Session.shutdown-session [self] (fn Session.shutdown-session [self]
(set self.queue []) (set self.queue [])
(set self.in-progress false) (set self.in-progress false)
(set self.sesion nil)) (set self.session nil))
(fn Session.cleanup-handlers [self] (fn Session.cleanup-handlers [self]
{:status/done #(self:done-msg) {:status/done #(self:done-msg)
@ -63,9 +63,11 @@
(fn Session.eval [self code ?handlers] (fn Session.eval [self code ?handlers]
(self:send {:op :eval : code} ?handlers)) (self:send {:op :eval : code} ?handlers))
(fn Session.input-handler [self input]
{:status/need-input #(self:send-oob {:op :stdin :stdin input})})
(fn Session.eval-input [self code input ?handlers] (fn Session.eval-input [self code input ?handlers]
(self:send {:op :eval : code} (self:send {:op :eval : code}
(lume.merge (or ?handlers {}) (lume.merge (or ?handlers {}) (self:input-handler input))))
{:status/need-input #(self:send-oob {:op :stdin :stdin input})})))
Session Session

2
link/serial.fnl
View file

@ -1,5 +1,5 @@
; using https://github.com/srdgame/librs232 ; using https://github.com/srdgame/librs232
(local rs232 (require :luars232)) (local (_ rs232) (pcall #(require :luars232)))
(local command (require "core.command")) (local command (require "core.command"))
(fn check [err ...] (fn check [err ...]

4
main.lua
View file

@ -1,11 +1,11 @@
-- bootstrap the compiler -- bootstrap the compiler
fennel = require("lib.fennel") fennel = require("lib.fennel")
table.insert(package.loaders, fennel.make_searcher({correlate=true})) table.insert(package.loaders, fennel.make_searcher())
fv = fennel.view fv = fennel.view
pp = function(x) print(fv(x)) end pp = function(x) print(fv(x)) end
lume = require("lib.lume") lume = require("lib.lume")
-- these set global variables and can't be required after requiring core.strict -- these set global variables and can't be required after requiring core.strict
luars232 = require("luars232") _, luars232 = pcall(function () require("luars232") end)
_coroutine_resume = coroutine.resume _coroutine_resume = coroutine.resume
function coroutine.resume(...) function coroutine.resume(...)

2
game/boop.fnl → neuttower/boop.fnl
View file

@ -1,4 +1,4 @@
(local {: vm} (require :game.defs)) (local {: vm} (require :neuttower.defs))
(local speaker :0xc030) (local speaker :0xc030)
(vm:def :blipmem ; count p -- (vm:def :blipmem ; count p --

2
game/bosskey.fnl → neuttower/bosskey.fnl
View file

@ -1,5 +1,5 @@
(local util (require :lib.util)) (local util (require :lib.util))
(local {: vm : prg : astr : style} (util.require :game.defs)) (local {: vm : prg : astr : style} (util.require :neuttower.defs))
(vm:word :boss-key :textmode :page2 (vm:until :read-key) :hires :page1) (vm:word :boss-key :textmode :page2 (vm:until :read-key) :hires :page1)
; if we upload to page 2 we don't have to worry about clobbering screen holes ; if we upload to page 2 we don't have to worry about clobbering screen holes

2
game/cheat.fnl → neuttower/cheat.fnl
View file

@ -1,4 +1,4 @@
(local {: vm : say-runon : say} (require :game.defs)) (local {: vm : say-runon : say} (require :neuttower.defs))
(fn defcheat [name ...] (fn defcheat [name ...]
(local cheatdata (.. name "-data")) (local cheatdata (.. name "-data"))

16
game/defs.fnl → neuttower/defs.fnl
View file

@ -4,6 +4,7 @@
(local asm (require :asm.asm)) (local asm (require :asm.asm))
(local VM (require :asm.vm)) (local VM (require :asm.vm))
(local tiles (require :game.tiles)) (local tiles (require :game.tiles))
(local files (require :game.files))
(local Prodos (require :asm.prodos)) (local Prodos (require :asm.prodos))
(local prg (asm.new)) (local prg (asm.new))
@ -133,7 +134,7 @@
(fn append-map [map org label] (fn append-map [map org label]
(org:append (org:append
[:align 0x100] label [:align 0x100] label
[:bytes (map.map:fromhex)] [:bytes map.map]
[:db (length map.objects)] [:db (length map.objects)]
[:dw (tiles.encode-yx map.jaye)] [:dw (tiles.encode-yx map.jaye)]
[:dw (tiles.encode-yx map.neut)] [:dw (tiles.encode-yx map.neut)]
@ -152,18 +153,18 @@
(vm:word :map-specific-move :map 250 :+ :execute) (vm:word :map-specific-move :map 250 :+ :execute)
(vm:word :map-specific-load :map 253 :+ :execute) (vm:word :map-specific-load :map 253 :+ :execute)
(fn deflevel [mapfile label] (fn deflevel [ilevel label]
(local level prg) ; todo: (asm.new prg) - if we want to load levels as an overlay (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 org level.vm.code) ; (level:org org.level.org) - if we want to give level data a stable loxation
(local map (readjson mapfile)) (local map (. files.game.levels ilevel))
(local entity (require :game.entity)) (local entity (require :neuttower.entity))
(append-map map org label) (append-map map org label)
(entity.append-from-map map org label) (entity.append-from-map map org label)
(set level.vm.code org) (set level.vm.code org)
level) level)
(fn say-runon [portrait ...] (fn say-runon [portrait ...]
(local result [:vm (.. :draw-p portrait)]) (local result [:vm (.. :draw-portrait- portrait)])
(local lines [...]) (local lines [...])
(local ilineOffset (if (< (length lines) 4) 1 0)) (local ilineOffset (if (< (length lines) 4) 1 0))
(each [iline line (ipairs lines)] (each [iline line (ipairs lines)]
@ -175,10 +176,9 @@
(table.insert result :dismiss-dialog) (table.insert result :dismiss-dialog)
result) result)
(local tilelist (tiles.loadgfx tiles.fn-tiles)) (fn itile [label] (tiles.find-itile files.game.tiles label))
(fn itile [label] (tiles.find-itile tilelist label))
(set vm.code org.code) (set vm.code org.code)
{: vm : prg : mapw : maph : mon : org : achar : astr : style : rot8l : deflevel : say : say-runon : itile : tilelist : controlstate} {: vm : prg : mapw : maph : mon : org : achar : astr : style : rot8l : deflevel : say : say-runon : itile : controlstate}

6
game/disk.fnl → neuttower/disk.fnl
View file

@ -3,7 +3,7 @@
(local Prodos (require :asm.prodos)) (local Prodos (require :asm.prodos))
(local util (require :lib.util)) (local util (require :lib.util))
(local {: lo : hi} util) (local {: lo : hi} util)
(local {: org} (require :game.defs)) (local {: org} (require :neuttower.defs))
(fn append-boot-loader [prg] (fn append-boot-loader [prg]
(local vm prg.vm) (local vm prg.vm)
@ -75,8 +75,8 @@
(create-sys-loader disk :NEUT game) (create-sys-loader disk :NEUT game)
(disk:add-file "TITLE.SCREEN" Prodos.file-type.BIN 0x2000 (: (util.readjson "game/title.screen") :fromhex)) (disk:add-file "TITLE.SCREEN" Prodos.file-type.BIN 0x2000 (: (util.readjson "neuttower/title.screen") :fromhex))
(disk:add-file "ELEVATOR.SCREEN" Prodos.file-type.BIN 0x2000 (: (util.readjson "game/end.screen") :fromhex)) (disk:add-file "ELEVATOR.SCREEN" Prodos.file-type.BIN 0x2000 (: (util.readjson "neuttower/end.screen") :fromhex))
(each [_ file (ipairs game.files)] (each [_ file (ipairs game.files)]
(disk:add-file file.filename Prodos.file-type.BIN file.org (. game.org-to-block file.org :bytes))) (disk:add-file file.filename Prodos.file-type.BIN file.org (. game.org-to-block file.org :bytes)))

0
game/end.screen → neuttower/end.screen
View file

2
game/entity.fnl → neuttower/entity.fnl
View file

@ -1,6 +1,6 @@
(local util (require :lib.util)) (local util (require :lib.util))
(local tiles (util.require :game.tiles)) (local tiles (util.require :game.tiles))
(local {: vm : org : itile : say : say-runon : controlstate} (require :game.defs)) (local {: vm : org : itile : say : say-runon : controlstate} (require :neuttower.defs))
(local {: lo : hi} util) (local {: lo : hi} util)
; Entity memory layout: ; Entity memory layout:

55
neuttower/footer.fnl Normal file
View file

@ -0,0 +1,55 @@
(local {: vm : org} (require :neuttower.defs))
(local {: hi : lo} (require :lib.util))
(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 ($1:lookup-addr :font))]
[:sta vm.TOPH :x])
(vm:word :draw-char ; pscreen c --
:lookup-pchar :draw-pchar)
(vm:word :draw-digit ; pscreen n --
0x30 :+ :draw-char)
(vm:word :snooze (vm:for))
(vm:word :textsnooze 0x30 :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)
(vm:var :footer-displayed vm.false)
(vm:word :show-footer :footer-displayed :get :not (vm:when vm.true :footer-displayed :set :drawfooter))
(vm:word :hide-footer :footer-displayed :get (vm:when vm.false :footer-displayed :set :clearfooter))

1
neuttower/game.json Normal file
View file

File diff suppressed because one or more lines are too long

2
game/gfx.fnl → neuttower/gfx.fnl
View file

@ -1,5 +1,5 @@
(local {: lo : hi} (require :lib.util)) (local {: lo : hi} (require :lib.util))
(local {: vm : mapw : maph : org} (require :game.defs)) (local {: vm : mapw : maph : org} (require :neuttower.defs))
; Graphics routines ; Graphics routines
(vm:def :mixed [:sta :0xc053]) (vm:def :mixed [:sta :0xc053])

65
neuttower/init.fnl Normal file
View file

@ -0,0 +1,65 @@
(local util (require :lib.util))
(local {: lo : hi : readjson} util)
(local tile (util.reload :game.tiles))
(local files (require :game.files))
(local {: prg : vm : org} (util.reload :neuttower.defs))
(local disk (util.reload :neuttower.disk))
(util.reload :neuttower.gfx)
(util.reload :neuttower.footer)
(util.reload :neuttower.map)
(util.reload :neuttower.entity)
(util.reload :neuttower.player)
(util.reload :neuttower.boop)
(util.reload :neuttower.cheat)
(tile.appendtiles org.code)
(org.code:append [:align 0x100] :font)
(tile.appendgfx org.code files.game.font)
(tile.append-portraitwords vm {:neut #[:vm :chuck-mode :get (vm:if [:lit :portrait-chuck] [:lit :portrait-neut])]})
(util.reload :neuttower.level1)
(util.reload :neuttower.level2)
(util.reload :neuttower.level3)
(util.reload :neuttower.level4)
(util.reload :neuttower.level5)
(util.reload :neuttower.level6)
(util.reload :neuttower.bosskey)
(vm:var :tick-count)
(vm:word :handle-key :tick :read-key :dup :cheat-key :player-key :hide-footer)
(vm:word :tick :map-specific-tick :tick-count :get 1 :+ :tick-count :set :player-redraw :rnd :drop)
(vm:var :next-level 0)
(vm:word :load-next-level :next-level :get :dup (vm:if [:load-level 0 :next-level :set] [:drop]))
(vm:word :load-level ; level-ptr --
:lit :map-ptr :set :reload-level)
(vm:word :reload-level
:map-jaye-yx :jaye-yx :set
:map-neut-yx :neut-yx :set
:map-gord-yx :gord-yx :set
0 :gord-dir :set
0xffff :rexx-yx :set
:map-specific-load
:full-redraw)
(vm.code:append :main
[:jsr :reset]
[:jsr :interpret]
[:vm :hires
:lit :level1 :load-level
(vm:forever
(vm:hotswap-sync :lit :level6 :load-level)
:interactive-eval-checkpoint
:handle-key
)
:quit])
(disk.append-boot-loader prg)
(prg:assemble)
(disk.write prg)
prg

13
game/level1.fnl → neuttower/level1.fnl
View file

@ -1,12 +1,13 @@
(local {: readjson} (require :lib.util)) (local {: readjson} (require :lib.util))
(local {: deflevel : say : itile : controlstate : tilelist} (require :game.defs)) (local {: deflevel : say : itile : controlstate} (require :neuttower.defs))
(local {: ev} (require :game.entity)) (local {: ev} (require :neuttower.entity))
(local {: decode-itile : encode-yx} (require :game.tiles)) (local {: decode-itile : encode-yx} (require :game.tiles))
(local level (deflevel "game/map1.json" :level1)) (local files (require :game.files))
(local level (deflevel 1 :level1))
(local vm level.vm) (local vm level.vm)
(let [map (readjson "game/map1.json") (let [map (. files.game.levels 1)
maptiles (map.map:fromhex) maptiles map.map
furniture-yx []] furniture-yx []]
(for [ibyte 1 (length maptiles)] (for [ibyte 1 (length maptiles)]
(let [btile (maptiles:sub ibyte ibyte) (let [btile (maptiles:sub ibyte ibyte)
@ -14,7 +15,7 @@
itile (+ (decode-itile enctile) 1) itile (+ (decode-itile enctile) 1)
mx (+ (% (- ibyte 1) 20) 1) mx (+ (% (- ibyte 1) 20) 1)
my (- 12 (math.floor (/ (- ibyte 1) 20)))] my (- 12 (math.floor (/ (- ibyte 1) 20)))]
(when (. tilelist itile :flags :debris) (when (. files.game.tiles itile :flags :debris)
(table.insert furniture-yx (encode-yx {:x mx :y my}))))) (table.insert furniture-yx (encode-yx {:x mx :y my})))))
(vm.code:append :furniture-yx) (vm.code:append :furniture-yx)
(for [_ 1 10] (for [_ 1 10]

6
neuttower/level2.fnl Normal file
View file

@ -0,0 +1,6 @@
(local {: deflevel : say : itile} (require :neuttower.defs))
(local {: ev} (require :neuttower.entity))
(local level (deflevel 2 :level2))
(local vm level.vm)
level

8
game/level3.fnl → neuttower/level3.fnl
View file

@ -1,8 +1,8 @@
(local {: deflevel : say : itile : controlstate} (require :game.defs)) (local {: deflevel : say : itile : controlstate} (require :neuttower.defs))
(local {: ev} (require :game.entity)) (local {: ev} (require :neuttower.entity))
(local level (deflevel "game/map3.json" :level3)) (local level (deflevel 3 :level3))
(local tile (require :game.tiles)) (local tile (require :game.tiles))
(local {: walkable : neutable : debris} tile.flag-to-bit) (local {: walkable : neutable : debris} (tile.flag-to-bit))
(local vm level.vm) (local vm level.vm)

6
game/level4.fnl → neuttower/level4.fnl
View file

@ -1,6 +1,6 @@
(local {: deflevel : say : itile} (require :game.defs)) (local {: deflevel : say : itile} (require :neuttower.defs))
(local {: ev} (require :game.entity)) (local {: ev} (require :neuttower.entity))
(local level (deflevel "game/map4.json" :level4)) (local level (deflevel 4 :level4))
(local vm level.vm) (local vm level.vm)
(vm:word :term-dual-link (vm:word :term-dual-link

13
game/level5.fnl → neuttower/level5.fnl
View file

@ -1,14 +1,15 @@
(local {: deflevel : say : itile : controlstate : tilelist} (require :game.defs)) (local {: deflevel : say : itile : controlstate} (require :neuttower.defs))
(local {: ev} (require :game.entity)) (local {: ev} (require :neuttower.entity))
(local tile (require :game.tiles)) (local tile (require :game.tiles))
(local {: notes} (require :game.boop)) (local files (require :game.files))
(local {: walkable : neutable : debris : sittable} tile.flag-to-bit) (local {: notes} (require :neuttower.boop))
(local level (deflevel "game/map5.json" :level5)) (local {: walkable : neutable : debris : sittable} (tile.flag-to-bit))
(local level (deflevel 5 :level5))
(local vm level.vm) (local vm level.vm)
(vm:word :snd-dropgarbage (notes [:a1] 0x02 0xf0)) (vm:word :snd-dropgarbage (notes [:a1] 0x02 0xf0))
(vm.code:append :debristiles) (vm.code:append :debristiles)
(each [itile tiledef (ipairs tilelist)] (each [itile tiledef (ipairs files.game.tiles)]
(when tiledef.flags.debris (when tiledef.flags.debris
(vm.code:append [:db (tile.encode-itile itile)]))) (vm.code:append [:db (tile.encode-itile itile)])))
(vm:word :randomgarbage :rnd 0x03 :& :lit :debristiles :+ :bget) (vm:word :randomgarbage :rnd 0x03 :& :lit :debristiles :+ :bget)

8
game/level6.fnl → neuttower/level6.fnl
View file

@ -1,8 +1,8 @@
(local {: deflevel : say : say-runon : itile : controlstate} (require :game.defs)) (local {: deflevel : say : say-runon : itile : controlstate} (require :neuttower.defs))
(local {: ev} (require :game.entity)) (local {: ev} (require :neuttower.entity))
(local tile (require :game.tiles)) (local tile (require :game.tiles))
(local {: walkable : neutable : debris : sittable} tile.flag-to-bit) (local {: walkable : neutable : debris : sittable} (tile.flag-to-bit))
(local level (deflevel "game/map6.json" :level6)) (local level (deflevel 6 :level6))
(local vm level.vm) (local vm level.vm)
(vm:word :linkloop ; e -- e (vm:word :linkloop ; e -- e

39
neuttower/map.fnl Normal file
View file

@ -0,0 +1,39 @@
(local {: lo : hi} (require :lib.util))
(local {: vm : mapw : maph : rot8l} (require :neuttower.defs))
(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 :map-at ; yx -- pmap
[: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 :map-page]
[:sta vm.TOPH :x])
(vm:word :itile-at ; yx -- itile
:map-at :bget)
(vm:word :update-itile ; yx itile --
:over :map-at :bset :drawtile-at)
(vm:word :drawtile-at ; yx --
:dup :yx>screen :swap
:itile-at :lookup-tile
:drawtile)

4
game/player.fnl → neuttower/player.fnl
View file

@ -1,7 +1,7 @@
(local tile (require :game.tiles)) (local tile (require :game.tiles))
(local {: vm : mapw : maph : itile : controlstate} (require :game.defs)) (local {: vm : mapw : maph : itile : controlstate} (require :neuttower.defs))
(local {: walkable : neutable : debris : sittable} tile.flag-to-bit) (local {: walkable : neutable : debris : sittable} (tile.flag-to-bit))
(vm:word :movement-dir ; key -- dyx (vm:word :movement-dir ; key -- dyx
(vm:case [(string.byte "I") 0xff00] (vm:case [(string.byte "I") 0xff00]

84
neuttower/tiles.fnl Normal file
View file

@ -0,0 +1,84 @@
(local util (require :lib.util))
(local lume (require :lib.lume))
(local flags [:walkable :neutable :debris :sittable])
(local flag-to-bit {})
(each [iflag flag (ipairs flags)]
(tset flag-to-bit flag (bit.lshift 1 (- iflag 1))))
(local encoded-tile-fields [:gfx :neut :mask])
(fn convert [tile field method]
(local oldval (. tile field))
(when oldval
(tset tile field (: oldval method)))
tile)
(fn convert-all [tile method]
(each [_ field (ipairs encoded-tile-fields)]
(convert tile field method))
tile)
(fn deserialize [tile]
(match (type tile)
:string {:gfx (tile:fromhex) :flags {}}
:table (convert-all tile :fromhex)))
(fn serialize [tile] (convert-all (lume.clone tile) :tohex))
(local fn-tiles "game/tiles.json")
(local fn-portraits "game/portraits.json")
(local fn-font "game/font.json")
(fn loadgfx [filename] (lume.map (util.readjson filename) deserialize))
(fn savegfx [filename gfx] (util.writejson filename (lume.map gfx serialize)))
(fn appendgfx [org gfx ?key ?ignore-labels]
(each [_ g (ipairs gfx)]
(when (and g.label (not ?ignore-labels)) (org:append g.label))
(org:append [:bytes (. g (or ?key :gfx))])))
(fn appendtiles [org]
(local tiles (loadgfx fn-tiles))
(org:append [:align 0x100] :jaye-tileset)
(appendgfx org tiles)
(org:append [:align 0x100] :neut-tileset)
(appendgfx org tiles :neut true)
(appendgfx org (loadgfx fn-portraits))
(org:append :tileflags)
(each [_ tile (ipairs tiles)]
(var flags 0)
(each [flag _ (pairs tile.flags)]
(set flags (bit.bor flags (. flag-to-bit flag))))
(org:append [:db flags])))
(fn append-portraitwords [vm ?overrides]
(local overrides (or ?overrides {}))
(each [_ p (ipairs (loadgfx fn-portraits))]
(let [wordname (.. :draw- p.label)
override (. overrides p.label)]
(vm:word (.. :draw- p.label) :show-footer
(if override (override p.label) [:vm :lit p.label])
:draw-portrait))))
(fn encode-yx [xy]
(if xy (bit.bor (bit.lshift (- xy.y 1) 8) (- xy.x 1)) 0xffff))
(fn encode-itile [itile]
(bit.bor
(bit.lshift (bit.band (- itile 1) 0x07) 5)
(bit.rshift (bit.band (- itile 1) 0xf8) 3)))
(fn decode-itile [enctile]
(+ 1 (bit.bor
(bit.lshift (bit.band enctile 0x1f) 3)
(bit.rshift (bit.band enctile 0xe0) 5))))
(fn find-itile [tiles label ?itilenext]
(local itile (or ?itilenext 1))
(local tile (. tiles itile))
(assert (not= tile nil) (.. "No such tile " label))
(if (= tile.label label) (encode-itile itile)
(find-itile tiles label (+ itile 1))))
{: loadgfx : savegfx : appendtiles : appendgfx : append-portraitwords : flags : flag-to-bit : find-itile
: fn-tiles : fn-portraits : fn-font : encode-yx : encode-itile : decode-itile}

0
game/title.screen → neuttower/title.screen
View file

31
presentation/commands.fnl Normal file
View file

@ -0,0 +1,31 @@
(local util (require :lib.util))
(local core (require :core))
(local command (require :core.command))
(local keymap (require :core.keymap))
(local SlideshowView (require :presentation.engine))
(fn set-scale [multiplier]
(set _G.SCALE (* (love.graphics.getDPIScale) multiplier))
(util.hotswap :core.style))
(command.add nil {
"presentation:start" (fn []
(let [node (core.root_view:get_active_node)]
(node:add_view (SlideshowView (util.reload :presentation.slides))))
)
"presentation:scale-up" #(set-scale 2)
"presentation:restore-scale" #(set-scale 1)
})
(command.add :presentation.engine {
"presentation:next" #(core.active_view:advance)
"presentation:prev" #(core.active_view:back)
"presentation:next-slide" #(core.active_view:next-slide)
"presentation:prev-slide" #(core.active_view:prev-slide)
})
(keymap.add {
"left" "presentation:prev"
"right" "presentation:next"
"ctrl+left" "presentation:prev-slide"
"ctrl+right" "presentation:next-slide"
})

107
presentation/engine.fnl Normal file
View file

@ -0,0 +1,107 @@
(local lume (require :lib.lume))
(local style (require :core.style))
(local common (require :core.common))
(local View (require :core.view))
(local SlideshowView (View:extend))
(fn SlideshowView.parse [slides]
(var style nil)
(icollect [_ slide (ipairs slides)]
(icollect [_ elem (ipairs slide)]
(match (type elem)
(where :table elem.style) (do (set style elem) nil)
:table elem
:string (lume.merge style {:text elem})))))
(fn SlideshowView.new [self slides]
(SlideshowView.super.new self)
(set self.slides slides)
(set self.imagecache {})
(set self.islide 1)
(set self.ielem 0)
(self:advance))
(fn SlideshowView.next-slide [self]
(set self.islide (if (>= self.islide (length self.slides)) 1 (+ self.islide 1)))
(set self.ielem 0)
(self:advance))
(fn SlideshowView.prev-slide [self]
(set self.islide (if (<= self.islide 1) (length self.slides) (- self.islide 1)))
(set self.ielem (+ 1 (length (. self.slides self.islide))))
(self:back))
(fn SlideshowView.ielemNext [self ielem di]
(let [slide (. self.slides self.islide)
elem (. slide ielem)]
(when elem
(if elem.pause-after ielem
(self:ielemNext (+ ielem di) di)))))
(fn SlideshowView.advance [self]
(let [ielemNext (self:ielemNext (+ self.ielem 1) 1)]
(if ielemNext (set self.ielem ielemNext)
(self:next-slide))))
(fn SlideshowView.back [self]
(let [ielemNext (self:ielemNext (- self.ielem 1) -1)]
(if ielemNext (set self.ielem ielemNext)
(self:prev-slide))))
(fn SlideshowView.load-image [self {:image filename}]
(when (= (. self.imagecache filename) nil)
(tset self.imagecache filename (love.graphics.newImage filename)))
(. self.imagecache filename))
(fn SlideshowView.justify [self element width]
(match element.justify
:center (/ (- self.size.x width) 2)
:right (- self.size.x width style.padding.x)
_ style.padding.x))
(fn SlideshowView.this-y [self element y]
(if element.topPadding (+ y element.topPadding)
(+ y style.padding.y)))
(fn SlideshowView.next-y [self element height y]
(if element.lowerPadding (+ y height element.lowerPadding)
element.overlay y
(+ y height style.padding.y)))
(fn SlideshowView.word-wrap [self element]
(let [letter-width (element.font:get_width "m")
screen-width (- self.size.x style.padding.x style.padding.x)
max-letters (math.floor (/ screen-width letter-width))
wrapped (lume.wordwrap element.text max-letters)
lines (icollect [line (string.gmatch wrapped "([^\n]+)")] line)]
lines))
(fn SlideshowView.render-element [self element y]
(if element.text
(let [lines (self:word-wrap element)
line-height (element.font:get_height)
full-height (+ (* line-height (length lines)) (* style.padding.y (- (length lines) 1)))]
(each [iline line (ipairs lines)]
(let [width (element.font:get_width line) ;; todo: word-wrapping
x (+ self.position.x (self:justify element width))
yline (+ y (* (+ (element.font:get_height) style.padding.y) (- iline 1)))]
(renderer.draw_text element.font line x yline element.color)))
(self:next-y element full-height y))
element.image
(let [image (self:load-image element)
x (+ self.position.x (self:justify element (image:getWidth)))]
(love.graphics.setColor 1 1 1 element.alpha)
(love.graphics.draw image x y)
(self:next-y element (image:getHeight) y))
y))
(fn SlideshowView.draw [self]
(self:draw_background style.background)
(var y self.position.y)
(each [ielem element (ipairs (. self.slides self.islide)) :until (> ielem self.ielem)]
(set y (self:render-element element (self:this-y element y)))))
(fn SlideshowView.get_name [self] "] KFest 2021")
SlideshowView

20
presentation/font/FreeLicense.txt Normal file
View file

@ -0,0 +1,20 @@
KREATIVE SOFTWARE RELAY FONTS FREE USE LICENSE
version 1.2f
Permission is hereby granted, free of charge, to any person or entity (the "User") obtaining a copy of the included font files (the "Software") produced by Kreative Software, to utilize, display, embed, or redistribute the Software, subject to the following conditions:
1. The User may not sell copies of the Software for a fee.
1a. The User may give away copies of the Software free of charge provided this license and any documentation is included verbatim and credit is given to Kreative Korporation or Kreative Software.
2. The User may not modify, reverse-engineer, or create any derivative works of the Software.
3. Any Software carrying the following font names or variations thereof is not covered by this license and may not be used under the terms of this license: Jewel Hill, Miss Diode n Friends, This is Beckie's font!
3a. Any Software carrying a font name ending with the string "Pro CE" is not covered by this license and may not be used under the terms of this license.
4. This license becomes null and void if any of the above conditions are not met.
5. Kreative Software reserves the right to change this license at any time without notice.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NONINFRINGEMENT OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF THE USE OR INABILITY TO USE THE SOFTWARE OR FROM OTHER DEALINGS IN THE SOFTWARE.

BIN
presentation/font/PRNumber3.ttf Normal file
View file

Binary file not shown.

BIN
presentation/font/PrintChar21.ttf Normal file
View file

Binary file not shown.

BIN
presentation/font/Shaston320.ttf Normal file
View file

Binary file not shown.

BIN
presentation/font/Shaston640.ttf Normal file
View file

Binary file not shown.

BIN
presentation/font/ShastonHi320.ttf Normal file
View file

Binary file not shown.

BIN
presentation/font/ShastonHi640.ttf Normal file
View file

Binary file not shown.

BIN
presentation/pics/assembly-markup.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 66 KiB

BIN
presentation/pics/ggj2020.jpeg Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 283 KiB

BIN
presentation/pics/pete286.jpeg Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 360 KiB

BIN
presentation/pics/thinkhard.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 306 KiB

91
presentation/slides.fnl Normal file
View file

@ -0,0 +1,91 @@
(local util (require :lib.util))
(local lume (require :lib.lume))
(local {: parse} (util.require :presentation.engine))
(local style (require :core.style))
(local h
{:style true
:font (renderer.font.load "presentation/font/PrintChar21.ttf" (* 64 SCALE))
:color style.caret
:justify :center
:topPadding (* style.padding.y 2)
:lowerPadding 64})
(local **
{:style true
:font (renderer.font.load "presentation/font/PRNumber3.ttf" (* 32 SCALE))
:color style.text
:justify :left
:pause-after true})
(fn p [style] (lume.merge style {:pause-after true}))
(fn np [style] (lume.merge style {:pause-after false}))
(fn bgimg [filename] {:image filename :justify :center :overlay true :alpha 0.3 :topPadding 0})
(parse [
[h "" ""
"Honeylisp" ""
(np **) "Jeremy Penner"
"https://spindleyq.itch.io/"
"https://blog.information-superhighway.net/"
"https://bitbucket.org/SpindleyQ/honeylisp"
"https://gamemaking.social/@SpindleyQ"
"https://twitter.com/SpindleyQ"
{:pause-after true}]
[(bgimg "presentation/pics/pete286.jpeg")
h "Some Background"
** "In 2019 I built a 16-bit MS-DOS game engine."
"* Built on hardware"
"* Using only period-appropriate software (Turbo C, NeoPaint)"
"* Powered by Forth"
"* Integrated custom tools"
"* Interactive development via serial terminal"]
[(bgimg "presentation/pics/ggj2020.jpeg")
h "Neut Tower"
** "In 2020, I did the Global Game Jam on my 286."
"Finished 'Shareware Episode 1' a couple of months later."]
[h "The Idea"
** "What if I took a similar DIY approach with modern tools?"
"* I'd done Forth; what about Lisp?"
"* How far can I push fast iterative development?"
"* Could I integrate an editor?"
"* How can I leverage emulation?"]
[h "Honeylisp"
** "* Written in Fennel, a Lisp that compiles to Lua"
"* Assembler"
"* Forth-like 'virtual machine' / inner interpreter"
"* 'lite' editor, ported to love2d"
" * Integrated custom editors"
"* MAME integration"
" * Upload new builds directly into RAM"
" * Interactive code injection"
" * Hot code reload"
"* Tape upload"
"* ProDOS disk image generation"]
;; DEMO before tech dive
[h "Assembler"
** "Represent instructions using Fennel data literals"
" [:lda 0xff]"
"Represent labels with Fennel strings"
" :loop [:bne :loop]"
"Lexical scope with nested blocks"
" [:block :loop (generate-loop-code) [:bne :loop]]"]
[h "Wait WTF Is An Assembler"
** "It's just converting mnemonics to bytes, right?"
{:image "presentation/pics/assembly-markup.png" :justify :center :pause-after true}
"Whoooops, actually the hard part is converting labels to addresses"
"Zero-page instructions are a different size, which messes up data layout!"
"Initial pass is needed to gather all symbols to determine sizes"
"What about data?"
" [:db 123] [:dw 12345] [:bytes \"HELLO WORLD\"] [:ref :hello]"
"Must be able to line up bytes on page boundaries"
" [:align 0x100]"]
[h "Virtual Machine"
{:image "presentation/pics/thinkhard.png" :justify :center}
** "Not super keen on writing a complicated compiler"
"I'm already very comfortable with Forth"
"Let's build a stack machine!"
"\"Direct threaded\" inner interpreter"
"\"Immediate words\" can be Fennel functions that generate code!"]
[h "Extensible Assembler??"
** "How do you turn code into bytes?"
" [:vm 1 2 :+ :.]"]
])

5
vendor/jeejah/jeejah/fenneleval.lua vendored
View file

@ -36,7 +36,7 @@ local make_repl = function(session, repls)
env.io = {} env.io = {}
end end
env.print = print_for(session.write) env.print = print_for(session.write)
env.io.write = session.write env.io.write = function(...) return session.io_write(...) end
env.io.read = function() env.io.read = function()
session.needinput() session.needinput()
local input, done = coroutine.yield() local input, done = coroutine.yield()
@ -63,6 +63,9 @@ return function(conn, msg, session, send, response_for)
session.values = function(xs) session.values = function(xs)
send(conn, response_for(msg, {value=table.concat(xs, "\n") .. "\n"})) send(conn, response_for(msg, {value=table.concat(xs, "\n") .. "\n"}))
end end
session.io_write = function(...)
send(conn, response_for(msg, {out=table.concat({...})}))
end
session.done = function() session.done = function()
send(conn, response_for(msg, {status={"done"}})) send(conn, response_for(msg, {status={"done"}}))
end end

2
vendor/lite/data/core/init.lua vendored
View file

@ -317,7 +317,7 @@ end
function core.try(fn, ...) function core.try(fn, ...)
local err local err
local ok, res = xpcall(fn, function(msg) local ok, res = xpcall(fn, function(msg)
print(debug.traceback()) print(msg, debug.traceback())
local item = core.error("%s", msg) local item = core.error("%s", msg)
item.info = debug.traceback(nil, 2):gsub("\t", "") item.info = debug.traceback(nil, 2):gsub("\t", "")
err = msg err = msg

2
vendor/lite/data/core/statusview.lua vendored
View file

@ -57,7 +57,7 @@ local function draw_items(self, items, x, y, draw_fn)
local color = style.text local color = style.text
for _, item in ipairs(items) do for _, item in ipairs(items) do
if type(item) == "userdata" then if type(item) == "userdata" or (type(item) == "table" and item.get_width) then
font = item font = item
elseif type(item) == "table" then elseif type(item) == "table" then
color = item color = item

15
wrap.fnl
View file

@ -5,8 +5,23 @@
(require :link.command) (require :link.command)
(local core (require :core)) (local core (require :core))
(local command (require :core.command)) (local command (require :core.command))
(local common (require :core.common))
(local keymap (require :core.keymap)) (local keymap (require :core.keymap))
(local translate (require :core.doc.translate)) (local translate (require :core.doc.translate))
(local files (require :game.files))
(command.add nil {
"honeylisp:open-project" (fn []
(core.command_view:enter "Open Project"
(fn [text item]
(files.reload (or (and item item.text) text))
(core.log "Opened"))
(fn [text]
(local files [])
(each [_ item (pairs core.project_files)]
(when (and (= item.type :file) (item.filename:find "^.*/game%.json"))
(table.insert files item.filename)))
(common.fuzzy_match files text))))})
(command.add #(link.machine:connected?) { (command.add #(link.machine:connected?) {
"honeylisp:upload" (fn [] "honeylisp:upload" (fn []