Fix codegen, implement 8bitsy dialog editor

asm/asm.fnl

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

editor/8bitsy.fnl

@@ -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))))))
+
+{}

editor/actions.fnl

@@ -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

editor/init.fnl

@@ -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")))

editor/mapedit.fnl

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

game/content.fnl

@@ -1,9 +1,4 @@
 ; TODO: Generate from data?
 (local {: vm : say : deflevel} (require :game.defs))
 
-(deflevel "game/map1.json" :map1)
+(deflevel 1 :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."))
-

game/defs.fnl

@@ -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 files.game.tiles label))
-(fn itile [label] (tiles.find-itile tilelist label))
 
 (set vm.code org.code)
 
-{: vm : prg : mapw : maph : mon : org : achar : astr : style : rot8l : deflevel : say : say-runon : itile : tilelist}
+{: vm : prg : mapw : maph : mon : org : achar : astr : style : rot8l : deflevel : say : say-runon : itile}
 

game/entity.fnl

@@ -100,10 +100,10 @@
     (entity-org:append
       (.. prefix "-entity-" ientity)
       [:db (- entity.x 1)] [:db (- entity.y 1)]
-      [:ref entity.func]
+      [:ref (if entity.advanced entity.func (.. prefix "-entity-word-" ientity))]
-      (if (and entity.linkword (> (length entity.linkword) 0)) [:ref entity.linkword] [:dw 0])
+      (if (and entity.advanced entity.linkword (> (length entity.linkword) 0)) [:ref entity.linkword] [:dw 0])
-      (if entity.link       [:ref (.. prefix "-entity-" entity.link)]
+      (if entity.link                             [:ref (.. prefix "-entity-" entity.link)]
-          entity.linkentity [:ref entity.linkentity]
+          (and entity.advanced entity.linkentity) [:ref entity.linkentity]
         [:dw 0]))))
 
 {: ev : append-from-map}

game/files.fnl

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

game/init.fnl

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

game/tiles.fnl

@@ -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 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]
-  (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]
   (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))]
+  (each [_ p (ipairs files.game.portraits)]
-    (let [wordname (.. :draw- p.label)
+    (let [wordname (.. :draw-portrait- 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))))
 
 (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
+{: appendtiles : appendgfx : append-portraitwords : flags : flag-to-bit : find-itile
- : fn-tiles : fn-portraits : fn-font : encode-yx : encode-itile : decode-itile : serialize : deserialize}
+ : encode-yx : encode-itile : decode-itile}
 

lib/fennel.lua

@@ -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
+    if (code:byte() == 40) then
-      return ("; " .. code)
+      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))))
-  
+
   {:-> ->*
    :->> ->>*
    :-?> -?>*