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

Fix codegen, implement 8bitsy dialog editor

Browse source
This commit is contained in:
Jeremy Penner 2021-04-24 23:39:50 -04:00
parent a8d77b232c
commit fdf69b8b11
14 changed files with 139 additions and 106 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

BIN
8Bitsy.dsk
View file

Binary file not shown.

3
asm/asm.fnl
View file

@ -179,7 +179,7 @@
(fn process-pdat [pdat process default ...]
(fn complain [ok ...]
(if ok (values ...)
(do (pp pdat) (error (.. process " failed in " pdat.type " near " (or pdat.nearest-symbol "<start of block>") " @" (or pdat.addr "<no address>") " - " ...)))))
(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))
(if processor (complain (pcall #(processor pdat $...) ...)) default))
@ -256,7 +256,6 @@
(local block-env (make-env block env))
(var bytes "")
(each [_ pdat (ipairs block.pdats)]
(print pdat.type pdat.addr pdat.nearest-symbol)
(process-pdat pdat :generate nil block-env)
(local pdatbytes (process-pdat pdat :bytes pdat.bytes block-env))
(assert (= (type pdatbytes) :string) (.. "failed to generate bytes: " (fv pdat)))

29
editor/8bitsy.fnl Normal file
View file

@ -0,0 +1,29 @@
(local util (require :lib.util))
(local actions (require :editor.actions))
(local {: textbox : dropdown } (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) 300)
(line1 y) (textbox view [:say :line1 i] (. lines 1) x (+ y style.padding.y) 300)
(line2 y) (textbox view [:say :line2 i] (. lines 2) x y 300)
(line3 y) (textbox view [:say :line3 i] (. lines 3) x y 300)
(line4 y) (textbox view [:say :line4 i] (. lines 4) x y 300)
]
(set action.character character)
(util.nested-tset action [:lines 1] line1)
(util.nested-tset action [:lines 2] line2)
(util.nested-tset action [:lines 3] line3)
(util.nested-tset action [:lines 4] line4)
y))
(fn [action vm]
(local {: say} (require :game.defs))
(say action.character (table.unpack (lume.map action.lines #($1:upper))))))
{}

7
editor/actions.fnl
View file

@ -9,4 +9,11 @@
(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 []))
(table.insert actions.actionlist key)
(defmethod actions.edit key edit)
(defmethod actions.generate key generate))
actions.hot

2
editor/init.fnl
View file

@ -9,6 +9,8 @@
(local keymap (require :core.keymap))
(local common (require :core.common))
(require :editor.8bitsy)
(let [commands {}]
(each [_ name (ipairs [:tile :portrait :font :brush :map])]
(local cls (require (.. "editor." name "edit")))

3
editor/mapedit.fnl
View file

@ -104,6 +104,7 @@
(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))
(var iobject-over nil)
(for [my 1 maph]
@ -130,7 +131,7 @@
(when (and self.itile (active? self :map) (mouse-inside tilex tiley tilew tileh) (not= itile self.itile))
(self:set-tile mx my self.itile))
(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)
:released
(if (and (not= iobject nil) (= self.iobject-linking iobject))

7
game/content.fnl
View file

@ -1,9 +1,4 @@
; TODO: Generate from data?
(local {: vm : say : deflevel} (require :game.defs))
(deflevel "game/map1.json" :map1)
(vm:word :cat (say :cat "I'M A CAT"))
(vm:word :fish (say :angryfish "I'M AN ANGRY FISH" "GRRRR"))
(vm:word :pot (say :player "IT'S A POT.") (say :player "NOTHING UNUSUAL ABOUT IT.") (say :player "JUST AN ORDINARY POT."))
(vm:word :suspiciouspot (say :player "IT'S A POT.") (say :player "NOTHING UNUSUAL ABOUT IT.") (say :player "JUST AN ORDINARY POT.") (say :player "YEP, NOTHING SPECIAL HERE."))
(deflevel 1 :map1)

24
game/defs.fnl
View file

@ -4,7 +4,9 @@
(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}))
@ -123,7 +125,7 @@
(fn append-map [map org label]
(org:append
[:align 0x100] label
[:bytes (map.map:fromhex)]
[:bytes map.map]
[:db (length map.objects)]
[:dw (tiles.encode-yx map.player)]
[:jmp (if (= (or map.tickword "") "") :next map.tickword)]
@ -138,18 +140,27 @@
(vm:word :map-specific-move :map 246 :+ :execute)
(vm:word :map-specific-load :map 249 :+ :execute)
(fn deflevel [mapfile label]
(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 []))]
(lume.push code (actions.generate action vm iaction)))
(vm:word (.. prefix ientity) (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 (readjson mapfile))
(local map (. files.game.levels ilevel))
(local entity (require :game.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-p portrait)])
(local result [:vm (.. :draw-portrait- portrait)])
(local lines [...])
(local ilineOffset (if (< (length lines) 4) 1 0))
(each [iline line (ipairs lines)]
@ -161,10 +172,9 @@
(table.insert result :dismiss-dialog)
result)
(local tilelist (tiles.loadgfx tiles.fn-tiles))
(fn itile [label] (tiles.find-itile tilelist label))
(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 : tilelist}
{: vm : prg : mapw : maph : mon : org : achar : astr : style : rot8l : deflevel : say : say-runon : itile}

8
game/entity.fnl
View file

@ -100,10 +100,10 @@
(entity-org:append
(.. prefix "-entity-" ientity)
[:db (- entity.x 1)] [:db (- entity.y 1)]
[:ref entity.func]
(if (and entity.linkword (> (length entity.linkword) 0)) [:ref entity.linkword] [:dw 0])
(if entity.link [:ref (.. prefix "-entity-" entity.link)]
entity.linkentity [:ref entity.linkentity]
[: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}

24
game/files.fnl
View file

@ -1,21 +1,39 @@
(local util (require :lib.util))
(local lume (require :lib.lume))
(local tile (require :game.tiles))
(local tiledraw (require :editor.tiledraw))
(local files (util.hot-table ...))
(local filename "game/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]
(each [_ field (ipairs encoded-tile-fields)]
(convert tile field method))
tile)
(fn tile-deserialize [tile]
(match (type tile)
:string {:gfx (tile:fromhex) :flags {}}
:table (convert-all tile :fromhex)))
(fn tile-serialize [tile] (convert-all (lume.clone tile) :tohex))
(fn deserialize [key value]
(match key
(where (or :tiles :portraits :font)) (tile.deserialize value)
(where (or :tiles :portraits :font)) (tile-deserialize value)
:levels (do (set value.map (value.map:fromhex)) value)
_ value))
(fn serialize [key value]
(match key
(where (or :tiles :portraits :font)) (tile.serialize value)
(where (or :tiles :portraits :font)) (tile-serialize value)
:levels (do (set value.map (value.map:tohex)) value)
_ value))

2
game/game.json
View file

File diff suppressed because one or more lines are too long

3
game/init.fnl
View file

@ -2,6 +2,7 @@
(local {: lo : hi : readjson} util)
(local tile (util.reload :game.tiles))
(local {: prg : vm : org} (util.reload :game.defs))
(local files (require :game.files))
(local disk (util.reload :game.disk))
@ -14,7 +15,7 @@
(tile.appendtiles org.code)
(org.code:append [:align 0x100] :font)
(tile.appendgfx org.code (tile.loadgfx tile.fn-font))
(tile.appendgfx org.code files.game.font)
(tile.append-portraitwords vm)
(vm:var :tick-count)

51
game/tiles.fnl
View file

@ -1,50 +1,21 @@
(local util (require :lib.util))
(local lume (require :lib.lume))
(local files (require :game.files))
(local flags [:walkable])
(local flag-to-bit {})
(each [iflag flag (ipairs flags)]
(tset flag-to-bit flag (bit.lshift 1 (- iflag 1))))
(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]
(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]
(if (util.file-exists 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]
(fn appendgfx [org gfx ?key ?label-prefix]
(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))])))
(fn appendtiles [org]
(local tiles (loadgfx fn-tiles))
(local tiles files.game.tiles)
(org:append [:align 0x100] :tileset)
(appendgfx org tiles)
(appendgfx org (loadgfx fn-portraits))
(appendgfx org files.game.portraits nil :portrait-)
(org:append :tileflags)
(each [_ tile (ipairs tiles)]
(var flags 0)
@ -54,11 +25,11 @@
(fn append-portraitwords [vm ?overrides]
(local overrides (or ?overrides {}))
(each [_ p (ipairs (loadgfx fn-portraits))]
(let [wordname (.. :draw- p.label)
(each [_ p (ipairs files.game.portraits)]
(let [wordname (.. :draw-portrait- p.label)
override (. overrides p.label)]
(vm:word (.. :draw- p.label) :show-footer
(if override (override p.label) [:vm :lit p.label])
(vm:word wordname :show-footer
(if override (override p.label) [:vm :lit (.. :portrait- p.label)])
:draw-portrait))))
(fn encode-yx [xy]
@ -81,6 +52,6 @@
(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 : serialize : deserialize}
{: appendtiles : appendgfx : append-portraitwords : flags : flag-to-bit : find-itile
: encode-yx : encode-itile : decode-itile}

82
lib/fennel.lua
View file

@ -2223,8 +2223,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
return table.concat(utils.map(exprs, 1), ", ")
end
local function disambiguate_parens(code, chunk)
if ((code:byte() == 40) and (1 < #chunk)) then
return ("; " .. code)
if (code:byte() == 40) then
return ("do end " .. code)
else
return code
end
@ -3712,13 +3712,13 @@ do
local builtin_macros = [===[;; This module contains all the built-in Fennel macros. Unlike all the other
;; modules that are loaded by the old bootstrap compiler, this runs in the
;; compiler scope of the version of the compiler being defined.
;; The code for these macros is somewhat idiosyncratic because it cannot use any
;; macros which have not yet been defined.
;; TODO: some of these macros modify their arguments; we should stop doing that,
;; but in a way that preserves file/line metadata.
(fn ->* [val ...]
"Thread-first macro.
Take the first value and splice it into the second form as its first argument.
@ -3729,7 +3729,7 @@ do
(table.insert elt 2 x)
(set x elt)))
x)
(fn ->>* [val ...]
"Thread-last macro.
Same as ->, except splices the value into the last position of each form
@ -3740,7 +3740,7 @@ do
(table.insert elt x)
(set x elt)))
x)
(fn -?>* [val ...]
"Nil-safe thread-first macro.
Same as -> except will short-circuit with nil when it encounters a nil value."
@ -3755,7 +3755,7 @@ do
(if ,tmp
(-?> ,el ,(unpack els))
,tmp)))))
(fn -?>>* [val ...]
"Nil-safe thread-last macro.
Same as ->> except will short-circuit with nil when it encounters a nil value."
@ -3770,14 +3770,14 @@ do
(if ,tmp
(-?>> ,el ,(unpack els))
,tmp)))))
(fn ?dot [tbl k ...]
"Nil-safe table look up.
Same as . (dot), except will short-circuit with nil when it encounters
a nil value in any of subsequent keys."
(if (= nil k) tbl `(let [res# (. ,tbl ,k)]
(and res# (?. res# ,...)))))
(fn doto* [val ...]
"Evaluates val and splices it into the first argument of subsequent forms."
(let [name (gensym)
@ -3787,7 +3787,7 @@ do
(table.insert form elt))
(table.insert form name)
form))
(fn when* [condition body1 ...]
"Evaluate body for side-effects only when condition is truthy."
(assert body1 "expected body")
@ -3795,7 +3795,7 @@ do
(do
,body1
,...)))
(fn with-open* [closable-bindings ...]
"Like `let`, but invokes (v:close) on each binding after evaluating the body.
The body is evaluated inside `xpcall` so that bound values will be closed upon
@ -3812,13 +3812,13 @@ do
`(let ,closable-bindings
,closer
(close-handlers# (xpcall ,bodyfn ,traceback)))))
(fn collect* [iter-tbl key-value-expr ...]
"Returns a table made by running an iterator and evaluating an expression
that returns key-value pairs to be inserted sequentially into the table.
This can be thought of as a \"table comprehension\". The provided key-value
expression must return either 2 values, or nil.
For example,
(collect [k v (pairs {:apple \"red\" :orange \"orange\"})]
(values v k))
@ -3834,12 +3834,12 @@ do
(match ,key-value-expr
(k# v#) (tset tbl# k# v#)))
tbl#))
(fn icollect* [iter-tbl value-expr ...]
"Returns a sequential table made by running an iterator and evaluating an
expression that returns values to be inserted sequentially into the table.
This can be thought of as a \"list comprehension\".
For example,
(icollect [_ v (ipairs [1 2 3 4 5])] (when (> v 2) (* v v)))
returns
@ -3853,7 +3853,7 @@ do
(each ,iter-tbl
(tset tbl# (+ (length tbl#) 1) ,value-expr))
tbl#))
(fn partial* [f ...]
"Returns a function with all arguments partially applied to f."
(assert f "expected a function to partially apply")
@ -3861,10 +3861,10 @@ do
(table.insert body _VARARG)
`(fn [,_VARARG]
,body)))
(fn pick-args* [n f]
"Creates a function of arity n that applies its arguments to f.
For example,
(pick-args 2 func)
expands to
@ -3876,10 +3876,10 @@ do
(tset bindings i (gensym)))
`(fn ,bindings
(,f ,(unpack bindings)))))
(fn pick-values* [n ...]
"Like the `values` special, but emits exactly n values.
For example,
(pick-values 2 ...)
expands to
@ -3894,7 +3894,7 @@ do
(if (= n 0) `(values)
`(let [,let-syms ,let-values]
(values ,(unpack let-syms))))))
(fn lambda* [...]
"Function literal with arity checking.
Will throw an exception if a declared argument is passed in as nil, unless
@ -3921,26 +3921,26 @@ do
,(tostring a)
,(or a.filename :unknown)
,(or a.line "?"))))))
(assert (= :table (type arglist)) "expected arg list")
(each [_ a (ipairs arglist)]
(check! a))
(if empty-body?
(table.insert args (sym :nil)))
`(fn ,(unpack args))))
(fn macro* [name ...]
"Define a single macro."
(assert (sym? name) "expected symbol for macro name")
(local args [...])
`(macros {,(tostring name) (fn ,(unpack args))}))
(fn macrodebug* [form return?]
"Print the resulting form after performing macroexpansion.
With a second argument, returns expanded form as a string instead of printing."
(let [handle (if return? `do `print)]
`(,handle ,(view (macroexpand form _SCOPE)))))
(fn import-macros* [binding1 module-name1 ...]
"Binds a table of macros from each macro module according to a binding form.
Each binding form can be either a symbol or a k/v destructuring table.
@ -3971,9 +3971,9 @@ do
(tostring modname)))
(tset scope.macros import-key (. subscope.macros macro-name))))))
nil)
;;; Pattern matching
(fn match-values [vals pattern unifications match-pattern]
(let [condition `(and)
bindings []]
@ -3984,7 +3984,7 @@ do
(each [_ b (ipairs subbindings)]
(table.insert bindings b))))
(values condition bindings)))
(fn match-table [val pattern unifications match-pattern]
(let [condition `(and (= (type ,val) :table))
bindings []]
@ -4016,7 +4016,7 @@ do
(each [_ b (ipairs subbindings)]
(table.insert bindings b)))))
(values condition bindings)))
(fn match-pattern [vals pattern unifications]
"Takes the AST of values and a single pattern and returns a condition
to determine if it matches as well as a list of bindings to
@ -4056,7 +4056,7 @@ do
(match-table val pattern unifications match-pattern)
;; literal value
(values `(= ,val ,pattern) []))))
(fn match-condition [vals clauses]
"Construct the actual `if` AST for the given match values and clauses."
(if (not= 0 (% (length clauses) 2)) ; treat odd final clause as default
@ -4070,7 +4070,7 @@ do
(table.insert out `(let ,bindings
,body))))
out))
(fn match-val-syms [clauses]
"How many multi-valued clauses are there? return a list of that many gensyms."
(let [syms (list (gensym))]
@ -4080,7 +4080,7 @@ do
(if (not (. syms valnum))
(tset syms valnum (gensym))))))
syms))
(fn match* [val ...]
;; Old implementation of match macro, which doesn't directly support
;; `where' and `or'. New syntax is implemented in `match-where',
@ -4090,9 +4090,9 @@ do
;; protect against multiple evaluation of the value, bind against as
;; many values as we ever match against in the clauses.
(list `let [vals val] (match-condition vals clauses))))
;; Construction of old match syntax from new syntax
(fn partition-2 [seq]
;; Partition `seq` by 2.
;; If `seq` has odd amount of elements, the last one is dropped.
@ -4112,7 +4112,7 @@ do
(if (not= nil v2)
(table.insert res [v1 v2]))))
res))
(fn transform-or [[_ & pats] guards]
;; Transforms `(or pat pats*)` lists into match `guard` patterns.
;;
@ -4121,7 +4121,7 @@ do
(each [_ pat (ipairs pats)]
(table.insert res (list pat `? (unpack guards))))
res))
(fn transform-cond [cond]
;; Transforms `where` cond into sequence of `match` guards.
;;
@ -4136,12 +4136,12 @@ do
[(list second `? (unpack cond 3))]))
:else
[cond]))
(fn match-where [val ...]
"Perform pattern matching on val. See reference for details.
Syntax:
(match data-expression
pattern body
(where pattern guard guards*) body
@ -4157,7 +4157,7 @@ do
(if else-branch
(table.insert match-body else-branch))
(match* val (unpack match-body))))
{:-> ->*
:->> ->>*
:-?> -?>*