git subrepo push --remote=git@github.com:jeremypenner/lite vendor/lite

subrepo:
  subdir:   "vendor/lite"
  merged:   "384d54f"
upstream:
  origin:   "git@github.com:jeremypenner/lite"
  branch:   "master"
  commit:   "384d54f"
git-subrepo:
  version:  "0.4.3"
  origin:   "???"
  commit:   "???"

asm/6502.fnl

@@ -0,0 +1,125 @@
+(local {: int8-to-bytes : int16-to-bytes} (require "lib.util"))
+
+(local opcodes {})
+
+; op mode arg
+; single-byte ops
+(let [ops
+      {:php 0x08 :plp 0x28 :pha 0x48 :pla 0x68 :dey 0x88 :tay 0xa8 :iny 0xc8 :inx 0xe8
+       :clc 0x18 :sec 0x38 :cli 0x58 :sei 0x78 :tya 0x98 :clv 0xb8 :cld 0xd8 :sed 0xf8
+       :txa 0x8a :txs 0x9a :tax 0xaa :tsx 0xba :dex 0xca :nop 0xea :rti 0x40 :rts 0x60}]
+  (each [opcode byte (pairs ops)]
+    (tset opcodes opcode (fn [mode] (if mode nil byte)))))
+(set opcodes.brk (fn [mode] (if (or (= mode :imm) (= mode nil)) 0x00 nil)))
+
+; branch ops
+(let [ops {:bpl 0x10 :bmi 0x30 :bvc 0x50 :bvs 0x70 :bcc 0x90 :bcs 0xb0 :bne 0xd0 :beq 0xf0}]
+  (each [opcode byte (pairs ops)]
+    (tset opcodes opcode (fn [mode] (if (= mode :rel) byte nil)))))
+(set opcodes.jsr (fn [mode] (if (= mode :abs) 0x20 nil)))
+
+; aaabbbcc ops
+(fn aaabbbcc [aaa cc modemap]
+  (local base (bit.bor cc (bit.lshift aaa 5)))
+  (fn [mode]
+    (local bbb (. modemap mode))
+    (if bbb (bit.bor base (bit.lshift bbb 2)) nil)))
+
+(fn indexed-modes [...]
+  (let [modemap {}]
+    (each [index mode (pairs [...])]
+      (tset modemap mode (- index 1)))
+    modemap))
+
+(fn without-modes [modemap ...]
+  (let [newmodemap (lume.clone modemap)]
+    (each [_ mode (pairs [...])]
+      (tset newmodemap mode nil))
+    newmodemap))
+
+(fn only-modes [modemap ...]
+  (let [newmodemap {}]
+    (each [_ mode (pairs [...])]
+      (tset newmodemap mode (. modemap mode)))
+    newmodemap))
+
+; cc=1 ops
+(let [cc1-modes (indexed-modes :zp-x* :zp :imm :abs :zp*-y :zp-x :abs-y :abs-x)
+      ops {:ora 0 :and 1 :eor 2 :adc 3 :lda 5 :cmp 6 :sbc 7}]
+  (each [opcode aaa (pairs ops)]
+    (tset opcodes opcode (aaabbbcc aaa 1 cc1-modes))
+  (tset opcodes :sta (aaabbbcc 4 1 (without-modes cc1-modes :imm)))))
+; cc=2 ops
+(let [cc2-modes (indexed-modes nil :zp :a :abs nil :zp-x nil :abs-x)]
+  (each [opcode aaa (pairs {:asl 0 :rol 1 :lsr 2 :ror 3})]
+    (tset opcodes opcode (aaabbbcc aaa 2 cc2-modes))
+  (each [opcode aaa (pairs {:dec 6 :inc 7})]
+    (tset opcodes opcode (aaabbbcc aaa 2 (without-modes cc2-modes :a))))))
+(tset opcodes :stx (aaabbbcc 4 2 (indexed-modes nil :zp nil :abs nil nil :zp-y)))
+(tset opcodes :ldx (aaabbbcc 5 2 (indexed-modes :imm :zp nil :abs nil nil :zp-y nil :abs-y)))
+
+; cc=0 ops
+(let [cc0-modes (indexed-modes :imm :zp nil :abs nil :zp-x nil :abs-x)]
+  (tset opcodes :bit (aaabbbcc 1 0 (only-modes cc0-modes :zp :abs)))
+  (tset opcodes :sty (aaabbbcc 4 0 (only-modes cc0-modes :zp :abs :zp-x)))
+  (tset opcodes :ldy (aaabbbcc 5 0 cc0-modes))
+  (each [opcode aaa (pairs {:cpy 6 :cpx 7})]
+    (tset opcodes opcode (aaabbbcc aaa 0 (only-modes cc0-modes :imm :zp :abs)))))
+(tset opcodes :jmp (fn [mode] (match mode :abs 0x4c :abs* 0x6c _ nil)))
+
+(fn parse-mode-arg [op]
+  (match op
+    [_ :a] [:a nil]
+    ([_ imm] ? (or (= (type imm) "number") (= (type imm) "function"))) [:imm imm]
+    ([opcode addr] ? (and (= (type addr) "string") (= (opcode:sub 1 1) "b"))) [:rel addr] ; branch
+    [_ addr :x] [:addr-x addr]
+    [_ [addr] :y] [:zp*-y addr]
+    [_ addr :y] [:addr-y addr]
+    [_ [addr :x]] [:zp-x* addr]
+    ([_ addr] ? (= (type addr) "string")) [:addr addr]
+    [_ [addr]] [:abs* addr]
+    [_] [nil nil]
+    _ (error (.. "Unrecognized syntax" (fv op)))))
+
+(local op-pdat {})
+
+(fn is-zp? [env name]
+  (match (env:lookup-org name)
+    org (< org 0x100)))
+
+(fn op-pdat.patch [op env]
+  (when (and op.mode (= (op.mode:sub 1 4) :addr))
+    (let [zp-mode (.. :zp (op.mode:sub 5))
+          abs-mode (.. :abs (op.mode:sub 5))
+          is-zp (and ((. opcodes op.opcode) zp-mode) (is-zp? env op.arg))]
+      (set op.mode (if is-zp zp-mode abs-mode)))))
+
+(fn op-pdat.size [{: mode}]
+  (if
+    (or (= mode nil) (= mode :a)) 1
+    (= (mode:sub 1 3) :abs) 3
+    2))
+
+(fn op-pdat.bytes [op env]
+  (local bytegen (. opcodes op.opcode))
+;   (pp op)
+  (if bytegen
+    (let [opbyte (bytegen op.mode)
+          argbytes
+          (if
+            (and (= op.mode :imm) (= (type op.arg) "function"))
+            (int8-to-bytes (op.arg env))
+
+            (= op.mode :imm) (int8-to-bytes op.arg)
+            (= op.mode :rel)
+              (int8-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 2)))
+            (= (op-pdat.size op) 2) (int8-to-bytes (env:lookup-addr op.arg))
+            (= (op-pdat.size op) 3) (int16-to-bytes (env:lookup-addr op.arg))
+            "")]
+      (if opbyte
+        (.. (int8-to-bytes opbyte) argbytes)
+        (error (.. op.opcode " doesn't support mode " op.mode))))
+    ""))
+
+
+{: opcodes : op-pdat : parse-mode-arg}

asm/65816.fnl

@@ -0,0 +1,146 @@
+(local {: int8-to-bytes : int16-to-bytes : int24-to-bytes} (require "lib.util"))
+
+(local opcodes {})
+
+; http://www.oxyron.de/html/opcodes816.html
+; The 65816 has an opcode for every possible byte. Rather than implementing any kind of tricky encoder logic, we just build a lookup table directly.
+(let [ops [[:brk nil]  [:ora :idx] [:cop :imm]  [:ora :sr]  [:tsb :dp]  [:ora :dp]  [:asl :dp]  [:ora :idl]  ; 0x00-0x07
+           [:php nil]  [:ora :imm] [:asl nil]   [:phd nil]  [:tsb :abs] [:ora :abs] [:asl :abs] [:ora :abl]  ; 0x08-0x0f
+           [:bpl :rel] [:ora :idy] [:ora :idp]  [:ora :isy] [:trb :dp]  [:ora :dpx] [:asl :dpx] [:ora :idly] ; 0x10-0x17
+           [:clc nil]  [:ora :aby] [:inc nil]   [:tcs nil]  [:trb :abs] [:ora :abx] [:asl :abx] [:ora :alx]  ; 0x18-0x1f
+           [:jsr :abs] [:and :idx] [:jsr :abl]  [:and :sr]  [:bit :dp]  [:and :dp]  [:rol :dp]  [:and :idl]  ; 0x20-0x27
+           [:plp nil]  [:and :imm] [:rol nil]   [:pld nil]  [:bit :abs] [:and :abs] [:rol :abs] [:and :abl]  ; 0x28-0x2f
+           [:bmi :rel] [:and :idy] [:and :idp]  [:and :isy] [:bit :dpx] [:and :dpx] [:rol :dpx] [:and :idly] ; 0x30-0x37
+           [:sec nil]  [:and :aby] [:dec nil]   [:tsc nil]  [:bit :abx] [:and :abx] [:rol :abx] [:and :alx]  ; 0x38-0x3f
+           [:rti nil]  [:eor :idx] [:wdm nil]   [:eor :sr]  [:mvp :bm]  [:eor :dp]  [:lsr :dp]  [:eor :idl]  ; 0x40-0x47
+           [:pha nil]  [:eor :imm] [:lsr nil]   [:phk nil]  [:jmp :abs] [:eor :abs] [:lsr :abs] [:eor :abl]  ; 0x48-0x4f
+           [:bvc :rel] [:eor :idy] [:eor :idp]  [:eor :isy] [:mvn :bm]  [:eor :dpx] [:lsr :dpx] [:eor :idly] ; 0x50-0x57
+           [:cli nil]  [:eor :aby] [:phy nil]   [:tcd nil]  [:jmp :abl] [:eor :abx] [:lsr :abx] [:eor :alx]  ; 0x58-0x5f
+           [:rts nil]  [:adc :idx] [:per :rell] [:adc :sr]  [:stz :dp]  [:adc :dp]  [:ror :zp]  [:adc :idl]  ; 0x60-0x67
+           [:pla nil]  [:adc :imm] [:ror nil]   [:rtl nil]  [:jmp :ind] [:adc :abs] [:ror :abs] [:adc :abl]  ; 0x68-0x6f
+           [:bvs :rel] [:adc :idy] [:adc :idp]  [:adc :isy] [:stz :dpx] [:adc :dpx] [:ror :zpx] [:adc :idly] ; 0x70-0x77
+           [:sei nil]  [:adc :aby] [:ply nil]   [:tdc nil]  [:jmp :iax] [:adc :abx] [:ror :abx] [:adc :alx]  ; 0x78-0x7f
+           [:bra :rel] [:sta :idx] [:brl :rell] [:sta :sr]  [:sty :dp]  [:sta :dp]  [:stx :dp]  [:sta :idl]  ; 0x80-0x87
+           [:dey nil]  [:bit :imm] [:txa nil]   [:phb nil]  [:sty :abs] [:sta :abs] [:stx :abs] [:sta :abl]  ; 0x88-0x8f
+           [:bcc :rel] [:sta :idy] [:sta :idp]  [:sta :isy] [:sty :dpx] [:sta :dpx] [:stx :dpy] [:sta :idly] ; 0x90-0x97
+           [:tya nil]  [:sta :aby] [:txs nil]   [:txy nil]  [:stz :abs] [:sta :abx] [:stz :abx] [:sta :alx]  ; 0x98-0x9f
+           [:ldy :imm] [:lda :idx] [:ldx :imm]  [:lda :sr]  [:ldy :dp]  [:lda :dp]  [:ldx :dp]  [:lda :idl]  ; 0xa0-0xa7
+           [:tay nil]  [:lda :imm] [:tax nil]   [:plb nil]  [:ldy :abs] [:lda :abs] [:ldx :abs] [:lda :abl]  ; 0xa8-0xaf
+           [:bcs :rel] [:lda :idy] [:lda :idp]  [:lda :isy] [:ldy :dpx] [:lda :dpx] [:ldx :dpy] [:lda :idly] ; 0xb0-0xb7
+           [:clv nil]  [:lda :aby] [:tsx nil]   [:tyx nil]  [:ldy :abx] [:lda :abx] [:ldx :aby] [:lda :alx]  ; 0xb8-0xbf
+           [:cpy :imm] [:cmp :idx] [:rep :imm]  [:cmp :sr]  [:cpy :dp]  [:cmp :dp]  [:dec :dp]  [:cmp :idl]  ; 0xc0-0xc7
+           [:iny nil]  [:cmp :imm] [:dex nil]   [:wai nil]  [:cpy :abs] [:cmp :abs] [:dec :abs] [:cmp :abl]  ; 0xc8-0xcf
+           [:bne :rel] [:cmp :idy] [:cmp :idp]  [:cmp :isy] [:pei :idp] [:cmp :dpx] [:dec :dpx] [:cmp :idly] ; 0xd0-0xd7
+           [:cld nil]  [:cmp :aby] [:phx nil]   [:stp nil]  [:jmp :ial] [:cmp :abx] [:dec :abx] [:cmp :alx]  ; 0xd8-0xdf
+           [:cpx :imm] [:sbc :idx] [:sep :imm]  [:sbc :sr]  [:cpx :dp]  [:sbc :dp]  [:inc :dp]  [:sbc :idl]  ; 0xe0-0xe7
+           [:inx nil]  [:sbc :imm] [:nop nil]   [:xba nil]  [:cpx :abs] [:sbc :abs] [:inc :abs] [:sbc :abl]  ; 0xe8-0xef
+           [:beq :rel] [:sbc :idy] [:sbc :idp]  [:sbc :isy] [:pea :imm] [:sbc :dpx] [:inc :dpx] [:sbc :idly] ; 0xf0-0xf7
+           [:sed nil]  [:sbc :aby] [:plx nil]   [:xce nil]  [:jsr :iax] [:sbc :abx] [:inc :abx] [:sbc :alx]  ; 0xf8-0xff
+          ]
+       mnemonic-to-modemap {}]
+  (each [iop [mnemonic mode] (ipairs ops)]
+    (when (= (. mnemonic-to-modemap mnemonic) nil)
+      (tset mnemonic-to-modemap mnemonic {}))
+    (tset mnemonic-to-modemap mnemonic (or mode :nil) (- iop 1)))
+  (each [mnemonic modemap (pairs mnemonic-to-modemap)]
+    (tset opcodes mnemonic (fn [mode] (. modemap (or mode :nil))))))
+(set opcodes.jsl #(when (= $1 :abl) 0x22)) ; allow forced long subroutine calls
+
+(fn dp-addr [addr]
+  (when (and (= (type addr) :string) (= (addr:sub 1 1) :d))
+    (tonumber (addr:sub 2))))
+(fn addr-parser [addr] (or (dp-addr addr) (tonumber addr)))
+
+(fn explicit-mode-arg [arg]
+  (var result nil)
+  (when (= (type arg) :table)
+    (each [mode arg (pairs arg)]
+      (when (= (type mode) :string)
+        (set result [mode arg]))))
+  result)
+
+(fn parse-mode-arg [op]
+  (match op
+    (where [_ arg] (explicit-mode-arg arg)) (explicit-mode-arg arg)
+    (where [mvx srcbank dstbank]
+           (= (type srcbank) :number) (= (type dstbank) :number) (= (mvx:sub 1 2) :mv))
+       [:bm [dstbank srcbank]] ; encoded backwards for some reason
+    [_ offset :s] [:sr offset]
+    [_ :#8 imm] [:imm8 imm]
+    (where [_ imm] (or (= (type imm) :number) (= (type imm) :function))) [:imm imm]
+    [_ [[addr]] :y] [:idly addr]
+    [_ [addr :s] :y] [:isy addr]
+    [_ [addr] :y] [:idy addr]
+    ; can tell ial / idl apart by the mnemonic
+    [:jmp [[addr]]] [:ial addr]
+    [_ [[addr]]] [:idl addr]
+    ; can tell iax / idx apart by the mnemonic
+    [:jmp [addr :x]] [:iax addr]
+    [:jsr [addr :x]] [:iax addr]
+    [_ [addr :x]] [:idx addr]
+    ; rell is the only valid mode for two mnemonics
+    [:per addr] [:rell addr]
+    [:brl addr] [:rell addr]
+    ; rel is the only valid mode for other branches
+    (where [br addr] (= (type addr) "string") (= (br:sub 1 1) "b") (not= br :bit)) [:rel addr]
+    (where [_ addr :x] (dp-addr addr)) [:dpx addr]
+    (where [_ addr :y] (dp-addr addr)) [:dpy addr]
+    (where [_ [addr]] (dp-addr addr)) [:idp addr]
+    (where [_ addr] (dp-addr addr)) [:dp addr]
+    [_ [addr]] [:ind addr]
+    [_ addr :y] [:aby addr]
+    [:jsl addr] [:abl addr] ; jsl is always long
+    ; we'll assume local bank for now and fix up bankswitching in :patch
+    [_ addr :x] [:abx addr]
+    [_ addr] [:abs addr]
+    [_] [nil nil]
+    _ (error (.. "Unrecognized syntax" (fv op)))))
+
+; abl = $000000
+; alx = $000000,X
+(local op-pdat {})
+(fn addr-page [addr] (math.floor (/ addr 0x10000)))
+(fn op-pdat.patch [op env]
+  (local long-mode (match op.mode :abs :abl :abx :alx))
+  (when (and long-mode
+             (not= (type op.arg) :function)
+             (not= (addr-page (env:lookup-org op.arg))
+                   (addr-page env.root-block.org)))
+    (set op.mode long-mode)))
+
+(fn op-pdat.size [op env]
+; TODO: handle 8-bit modes
+  (match op.mode
+    (where (or :sr :dp :dpx :dpy :idp :idx :idy :idl :idly :isy :rel)) 2
+    :imm8 2
+    :imm (match op.opcode
+           (where (or :cop :brk :sep :rep)) 2
+           _ 3)
+    (where (or :abs :abx :aby :ind :iax :rell :bm)) 3
+    (where (or :abl :alx :ial)) 4
+    nil 1
+    _ (error (.. "unknown mode " op.mode))))
+
+(fn op-pdat.bytes [op env]
+  (local bytegen (. opcodes op.opcode))
+  (if bytegen
+    (let [opbyte (bytegen (if (= op.mode :imm8) :imm op.mode))
+          arg (if (= (type op.arg) :function) (op.arg env) op.arg)
+          argbytes
+          (if
+            (or (= op.mode :sr) (= op.mode :isy) (= op.mode :imm8)) (int8-to-bytes arg)
+            (= op.mode :bm) (.. (int8-to-bytes (. arg 1)) (int8-to-bytes (. arg 2)))
+            (and (= op.mode :imm) (= (op-pdat.size op env) 3)) (int16-to-bytes arg)
+            (and (= op.mode :imm) (= (op-pdat.size op env) 2)) (int8-to-bytes arg)
+            (= op.mode :rel)  (int8-to-bytes (- (env:lookup-addr arg) (+ op.addr 2)))
+            (= op.mode :rell) (int16-to-bytes (- (env:lookup-addr arg) (+ op.addr 3)))
+            (= (op-pdat.size op env) 2) (int8-to-bytes (env:lookup-addr arg))
+            (= (op-pdat.size op env) 3) (int16-to-bytes (env:lookup-addr arg))
+            (= (op-pdat.size op env) 4) (int24-to-bytes (env:lookup-addr arg))
+            "")]
+      (if opbyte
+        (.. (int8-to-bytes opbyte) argbytes)
+        (error (.. op.opcode " doesn't support mode " op.mode))))
+    ""))
+
+{: opcodes : parse-mode-arg : op-pdat : addr-parser}

asm/asm.fnl

@@ -1,98 +1,16 @@
 (local lume (require "lib.lume"))
-(local {: int8-to-bytes : int16-to-bytes} (require "lib.util"))
-(local opcodes {})
-
-; op mode arg
-; single-byte ops
-(let [ops
-      {:php 0x08 :plp 0x28 :pha 0x48 :pla 0x68 :dey 0x88 :tay 0xa8 :iny 0xc8 :inx 0xe8
-       :clc 0x18 :sec 0x38 :cli 0x58 :sei 0x78 :tya 0x98 :clv 0xb8 :cld 0xd8 :sed 0xf8
-       :txa 0x8a :txs 0x9a :tax 0xaa :tsx 0xba :dex 0xca :nop 0xea :rti 0x40 :rts 0x60}]
-  (each [opcode byte (pairs ops)]
-    (tset opcodes opcode (fn [mode] (if mode nil byte)))))
-(set opcodes.brk (fn [mode] (if (or (= mode :imm) (= mode nil)) 0x00 nil)))
-
-; branch ops
-(let [ops {:bpl 0x10 :bmi 0x30 :bvc 0x50 :bvs 0x70 :bcc 0x90 :bcs 0xb0 :bne 0xd0 :beq 0xf0}]
-  (each [opcode byte (pairs ops)]
-    (tset opcodes opcode (fn [mode] (if (= mode :rel) byte nil)))))
-(set opcodes.jsr (fn [mode] (if (= mode :abs) 0x20 nil)))
-
-; aaabbbcc ops
-(fn aaabbbcc [aaa cc modemap]
-  (local base (bit.bor cc (bit.lshift aaa 5)))
-  (fn [mode]
-    (local bbb (. modemap mode))
-    (if bbb (bit.bor base (bit.lshift bbb 2)) nil)))
-
-(fn indexed-modes [...]
-  (let [modemap {}]
-    (each [index mode (pairs [...])]
-      (tset modemap mode (- index 1)))
-    modemap))
-
-(fn without-modes [modemap ...]
-  (let [newmodemap (lume.clone modemap)]
-    (each [_ mode (pairs [...])]
-      (tset newmodemap mode nil))
-    newmodemap))
-
-(fn only-modes [modemap ...]
-  (let [newmodemap {}]
-    (each [_ mode (pairs [...])]
-      (tset newmodemap mode (. modemap mode)))
-    newmodemap))
-
-; cc=1 ops
-(let [cc1-modes (indexed-modes :zp-x* :zp :imm :abs :zp*-y :zp-x :abs-y :abs-x)
-      ops {:ora 0 :and 1 :eor 2 :adc 3 :lda 5 :cmp 6 :sbc 7}]
-  (each [opcode aaa (pairs ops)]
-    (tset opcodes opcode (aaabbbcc aaa 1 cc1-modes))
-  (tset opcodes :sta (aaabbbcc 4 1 (without-modes cc1-modes :imm)))))
-; cc=2 ops
-(let [cc2-modes (indexed-modes nil :zp :a :abs nil :zp-x nil :abs-x)]
-  (each [opcode aaa (pairs {:asl 0 :rol 1 :lsr 2 :ror 3})]
-    (tset opcodes opcode (aaabbbcc aaa 2 cc2-modes))
-  (each [opcode aaa (pairs {:dec 6 :inc 7})]
-    (tset opcodes opcode (aaabbbcc aaa 2 (without-modes cc2-modes :a))))))
-(tset opcodes :stx (aaabbbcc 4 2 (indexed-modes nil :zp nil :abs nil nil :zp-y)))
-(tset opcodes :ldx (aaabbbcc 5 2 (indexed-modes :imm :zp nil :abs nil nil :zp-y nil :abs-y)))
-
-; cc=0 ops
-(let [cc0-modes (indexed-modes :imm :zp nil :abs nil :zp-x nil :abs-x)]
-  (tset opcodes :bit (aaabbbcc 1 0 (only-modes cc0-modes :zp :abs)))
-  (tset opcodes :sty (aaabbbcc 4 0 (only-modes cc0-modes :zp :abs :zp-x)))
-  (tset opcodes :ldy (aaabbbcc 5 0 cc0-modes))
-  (each [opcode aaa (pairs {:cpy 6 :cpx 7})]
-    (tset opcodes opcode (aaabbbcc aaa 0 (only-modes cc0-modes :imm :zp :abs)))))
-(tset opcodes :jmp (fn [mode] (match mode :abs 0x4c :abs* 0x6c _ nil)))
-
-(fn size [mode]
-  (if
-    (or (= mode nil) (= mode :a)) 1
-    (= (mode:sub 1 3) :abs) 3
-    2))
-(fn opsize [op] (if (= op.opcode :block) 0 (size op.mode)))
-
-(fn parse-mode-arg [op]
-  (match op
-    [_ :a] [:a nil]
-    ([_ imm] ? (or (= (type imm) "number") (= (type imm) "function"))) [:imm imm]
-    ([opcode addr] ? (and (= (type addr) "string") (= (opcode:sub 1 1) "b"))) [:rel addr] ; branch
-    [_ addr :x] [:addr-x addr]
-    [_ [addr] :y] [:zp*-y addr]
-    [_ addr :y] [:addr-y addr]
-    [_ [addr :x]] [:zp-x* addr]
-    ([_ addr] ? (= (type addr) "string")) [:addr addr]
-    [_ [addr]] [:abs* addr]
-    [_] [nil nil]
-    _ (error (.. "Unrecognized syntax" (fv op)))))
+(local {: int8-to-bytes : int16-to-bytes : int24-to-bytes : int32-to-bytes} (require "lib.util"))
 
 (fn make-env [block parent]
   {:parent parent
+   :prg (or parent.prg parent)
+   :root-block (or parent.root-block block)
    :block block
-   ; todo: support local self-reference if org is set to zp
-   :is-zp? (fn [self name] (if (. self.block.symbols name) false (self.parent:is-zp? name)))
+   :lookup-org
+   (fn [self name]
+     (if (or (. self.block.symbols name) (. self.block.globals name))
+       self.root-block.org
+       (self.parent:lookup-org name)))
    :lookup-addr
    (fn [self name]
      (local ipdat (. self.block.symbols name))
@@ -110,7 +28,8 @@
 
        (self.parent:lookup-addr name)))})
 
-(fn program [prg-base]
+(fn program [prg-base ?processor]
+  (local {: opcodes : op-pdat : parse-mode-arg : addr-parser} (require (.. :asm. (or ?processor :6502))))
   ; dat - anything that takes up space in the assembled output (op, dw, db, etc)
   ;   takes the form [:op args]
   ; pdat - a parsed dat; takes the form {:type type :addr addr ...}
@@ -130,11 +49,14 @@
 
         (let [opcode (. dat 1)
               parser (. dat-parser opcode)
+              meta (getmetatable dat)
               pdat
               (if parser (parser dat block)
                   (. opcodes opcode) (dat-parser.op dat)
                   (error (.. "Unrecognized opcode " (fv opcode))))]
           (when pdat
+            (when meta (set block.last-meta meta))
+            (set pdat.meta block.last-meta)
             (set pdat.nearest-symbol block.last-symbol)
             (table.insert block.pdats pdat)
             (when pdat.globals
@@ -154,10 +76,11 @@
       (table.remove dats 1)
       (parse-dats (new-block block.last-symbol) dats)))
 
-  (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.bytes [bytes] {:type :raw :bytes (. bytes 2)})
-  (fn dat-parser.ref [ref]     {:type :ref :target (. ref 2)})
+  (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.dl [dl]           {:type :var :init (. dl 2) :size 4})
+  (fn dat-parser.bytes [[_ bytes]] {:type :raw :bytes (if (= (type bytes) :table) (string.char (table.unpack bytes)) bytes)})
+  (fn dat-parser.ref [ref]         {:type :ref :target (. ref 2)})
   (fn dat-parser.flatten [flat block]
     (parse-dats block (lume.slice flat 2))
     nil)
@@ -169,6 +92,7 @@
     nil)
 
   (fn dat-parser.align [pad] {:type :pad :align (. pad 2)})
+  (fn dat-parser.meta [[_ f]] {:type :meta :bytes "" :size 0 : f})
   (fn dat-parser.hot-preserve [[_ label & dats] block]
     (let [preserve-block (new-block)]
       (tset block.preserved label preserve-block)
@@ -178,56 +102,33 @@
       preserve-block))
 
   (local pdat-processor {
-    :op {}
+    :op op-pdat
     :var {}
     :ref {}
     :raw {}
     :block {}
     :pad {}
+    :meta {}
   })
 
+  (fn describe-pdat [pdat]
+    (if pdat.meta (.. pdat.meta.filename "@" pdat.meta.line)
+      (.. (or pdat.nearest-symbol "<start of block>") " @" (or pdat.addr "<no address>"))))
+
   (fn process-pdat [pdat process default ...]
     (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>") " - " ...)))))
+          (do (error (.. process " failed in " pdat.type " near " (describe-pdat pdat) " - " ...)))))
     (local processor (. pdat-processor pdat.type process))
     (if processor (complain (pcall #(processor pdat $...) ...)) default))
 
-  (fn pdat-processor.op.patch [op env]
-    (when (and op.mode (= (op.mode:sub 1 4) :addr))
-      (let [zp-mode (.. :zp (op.mode:sub 5))
-            abs-mode (.. :abs (op.mode:sub 5))
-            is-zp (and ((. opcodes op.opcode) zp-mode) (env:is-zp? op.arg))]
-        (set op.mode (if is-zp zp-mode abs-mode)))))
-
   (fn pdat-processor.raw.size [raw] (length raw.bytes))
-  (fn pdat-processor.op.size [op] (size op.mode))
   (fn pdat-processor.var.size [d] d.size)
   (fn pdat-processor.ref.size [r] 2)
   (fn pdat-processor.pad.size [pad]
     (let [misalignment (% pad.addr pad.align)]
       (if (= misalignment 0) 0
         (- pad.align misalignment))))
-  (fn pdat-processor.op.bytes [op env]
-    (local bytegen (. opcodes op.opcode))
-  ;   (pp op)
-    (if bytegen
-      (let [opbyte (bytegen op.mode)
-            argbytes
-            (if
-              (and (= op.mode :imm) (= (type op.arg) "function"))
-              (int8-to-bytes (op.arg env))
-
-              (= op.mode :imm) (int8-to-bytes op.arg)
-              (= op.mode :rel)
-                (int8-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 2)))
-              (= (size op.mode) 2) (int8-to-bytes (env:lookup-addr op.arg))
-              (= (size op.mode) 3) (int16-to-bytes (env:lookup-addr op.arg))
-              "")]
-        (if opbyte
-          (.. (int8-to-bytes opbyte) argbytes)
-          (error (.. op.opcode " doesn't support mode " op.mode))))
-      ""))
   (fn pdat-processor.var.bytes [d env]
     (local init (match (type d.init)
                   :number d.init
@@ -236,11 +137,14 @@
     (match d.size
       1 (int8-to-bytes init)
       2 (int16-to-bytes init)
+      3 (int24-to-bytes init)
+      4 (int32-to-bytes init)
       n (string.rep "\0" n)))
   (fn pdat-processor.ref.bytes [ref env]
     (int16-to-bytes (env:lookup-addr ref.target)))
 
   (fn pdat-processor.pad.bytes [pad] (string.rep "\0" pad.size))
+  (fn pdat-processor.meta.generate [{: f : addr} env] (f addr env))
   (fn pdat-processor.block.symbols [block]
     (lume.concat (lume.keys block.symbols) (lume.keys block.globals)))
 
@@ -297,7 +201,8 @@
      (var block (. self.org-to-block org))
      (when (not block)
        (set block (new-block))
-       (tset self.org-to-block org block))
+       (tset self.org-to-block org block)
+       (set block.org org))
      {: block
       : org
       :prg self
@@ -305,14 +210,8 @@
       :append (fn [self ...] (self.prg:dbg self.org ...) (parse-dats self.block [...]) self)})
    :parse-addr
    (fn [self name]
-     (local addr (tonumber name))
+     (local addr ((or addr-parser tonumber) name))
      (if addr addr (error (.. "Symbol '" name "' not found"))))
-   :is-zp?
-   (fn [self name]
-     (local org (. self.symbol-to-org name))
-     (if org (< org 0x100)
-         self.prg-base (self.prg-base:is-zp? name)
-       (< (self:parse-addr name) 0x100)))
    :env-lookup
    (fn [self name lookup ...]
      (local org (. self.symbol-to-org name))
@@ -324,6 +223,9 @@
    (fn [self name]
 ;       (print "looking up" name "in" self)
       (or (self:env-lookup name :lookup-addr) (self:parse-addr name)))
+   :lookup-org
+   (fn [self name]
+     (or (self:env-lookup name :lookup-org) (self:parse-addr name)))
    :pass
    (fn [self passname]
      (print passname)
@@ -349,15 +251,16 @@
        (set self.dbgfile nil))
      self)
    :read-hotswap
-   (fn [self machine]
+   (fn [self machine prg-new]
      (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))))
+       (lume.merge (collect [addr bytes (pairs (machine:read-batch addr-to-size))]
+                     (values (. addr-to-label addr) bytes))
+                   (if (?. self.source :read-hotswap) (self.source:read-hotswap machine prg-new) {}))))
    :write-hotswap
    (fn [self machine hotswap]
      (machine:write-batch

editor/8bitsy.fnl

@@ -1,41 +1,40 @@
 (local util (require :lib.util))
 (local actions (require :editor.actions))
-(local {: textbox : dropdown : textfield} (util.require :editor.imstate))
+(local {: textbox : dropdown : textfield : label : under : right-of : reform : group-wrapper} (util.require :editor.imgui))
 (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)
+  (fn [action form i]
+    (let [characters (lume.map (or 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)]
+          character (dropdown (under form {:tag [:say :char i] :w form.w}) character characters)
+          line1 (textbox (under form {:tag [:say :line1 i] :w form.w}) (or (. lines 1) ""))
+          line2 (textbox (under form {:tag [:say :line2 i] :w form.w}) (or (. lines 2) ""))
+          line3 (textbox (under form {:tag [:say :line3 i] :w form.w}) (or (. lines 3) ""))
+          line4 (textbox (under form {:tag [:say :line4 i] :w form.w}) (or (. lines 4) ""))]
       (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))
+      (util.nested-tset action [:lines 4] (line4:sub 1 33))))
   (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))
+  (fn [action form i]
+    (let [g (group-wrapper form)
+          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 SCALE))
-          (position-string y) (textbox view [:warp :loc i] (string.format "%x" (or action.position 0)) (+ x (* 150 SCALE)) y (* 150 SCALE))
+          map (g dropdown (under form {:tag [:warp :map i] :w (- (/ form.w 2) form.xpad)}) map maps)
+          position-string (g textbox (right-of form {:tag [:warp :loc i] :w form.w})   (string.format "%x" (or action.position 0)))
           position (or (tonumber position-string 16) action.position)]
       (set action.map map)
       (set action.position position)
-      y))
+      (g)))
   (fn [action vm]
     (values :move-to-responder action.position :lit action.map :map-player-yx-ptr :set :lit action.map :next-level :set)))
 
@@ -43,20 +42,17 @@
 (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 SCALE))
-          x (renderer.draw_text style.font " to " (+ x (* 100 SCALE)) y style.text)
+  (fn [action form i]
+    (let [g (group-wrapper form)
           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 SCALE))]
-      (set action.flag flag)
-      (set action.rhs rhs)
-      y))
+          rhs (or action.rhs (. options 1))]
+      (g label (reform form) "Set ")
+      (set action.flag (g dropdown (right-of form {:tag [:set-flag :flag i] :w (* 100 SCALE)}) action.flag files.game.flags))
+      (g label (right-of form) " to ")
+      (set action.rhs (g dropdown (right-of form {:tag [:set-flag :rhs i] :w (* 100 SCALE)}) rhs options))
+      (g)))
   (fn [action vm]
     (values action.rhs.value (.. :cond-var- action.flag) :set)))
 

editor/actions.fnl

@@ -1,13 +1,12 @@
 (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))
+(defmethod actions.edit :default (fn [action form i]))
 
 (fn actions.register [key edit generate]
   (when (= actions.actionlist nil)
@@ -18,6 +17,6 @@
   (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.register key (fn [action form i]) #generated-value))
 
 actions.hot

editor/fontedit.fnl

@@ -2,18 +2,18 @@
 (local tiledraw (require :editor.tiledraw))
 (local tiles (require :game.tiles))
 (local style (require :core.style))
+(local files (require :game.files))
 
 (local FontEditView (TileView:extend))
 
-(fn FontEditView.tilesize [self] (values 8 8))
 (fn FontEditView.tilekeys [self] [:gfx])
-(fn FontEditView.map-bitxy [self x y] (values y x))
-(fn FontEditView.draw-tile-flags [self x y]
+(fn FontEditView.draw-sidebar [self {: x : y}]
   (when self.itile
     (local char (string.char (+ self.itile 0x20 -1)))
     (renderer.draw_text style.big_font char x y style.text))
   (love.graphics.setColor 1 1 1 1))
-(fn FontEditView.resource-key [self] :font)
+
+(fn FontEditView.initial-style [self] :font)
 (fn FontEditView.get_name [self] "Font Editor")
 
 FontEditView

editor/gfxedit.fnl

@@ -3,7 +3,7 @@
 (local tiledraw (require :editor.tiledraw))
 (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 : button : reform : horiz-wrapper : group-wrapper} (util.require :editor.imgui))
 
 (local GraphicsEditView (View:extend))
 
@@ -12,15 +12,19 @@
 
 (fn GraphicsEditView.new [self]
   (GraphicsEditView.super.new self)
-  (set self.tilecache (files.cache (self:resource-key)))
-  (set self.itile 1)
+  (self:set-style (self:initial-style))
   (set self.scrollheight math.huge)
   (set self.scrollable true)
   (attach-imstate self))
 (fn GraphicsEditView.get_scrollable_size [self] self.scrollheight)
-(fn GraphicsEditView.resource-key [self] :tiles)
-(fn GraphicsEditView.tilesize [self] (values 16 16))
-(fn GraphicsEditView.tilebytelen [self] (let [(w h) (self:tilesize)] (/ (* w h) 8)))
+(fn GraphicsEditView.initial-style [self] :tiles)
+(fn GraphicsEditView.tilesize [self]
+  (let [style (tiles.style self.style)]
+    (values (or style.editw style.tilew) (or style.edith style.tileh))))
+(fn GraphicsEditView.set-style [self key]
+  (set self.style key)
+  (set self.tilecache (files.cache key))
+  (set self.itile 1))
 (fn GraphicsEditView.reload [self] (files.reload))
 (fn GraphicsEditView.save [self] (files.save))
 
@@ -30,26 +34,31 @@
     (when (>= itile 1) (set self.itile itile))))
 
 (fn GraphicsEditView.draw-sprite [self x y itile ?key]
-  (love.graphics.draw (self.tilecache:sprite itile ?key) x y 0 self.sprite-scale self.sprite-scale))
+  (let [sprite (self.tilecache:sprite itile ?key)]
+    (when sprite
+      (love.graphics.setColor 1 1 1)
+      (love.graphics.draw sprite x y 0 self.sprite-scale self.sprite-scale)
+      (values (* (sprite:getWidth) self.sprite-scale) (* (sprite:getHeight) self.sprite-scale)))))
 
-(fn GraphicsEditView.draw-tile-selector [self x y w ?key]
-  (var tilex x)
-  (var tiley y)
-  (var (pixw pixh) (self:tilesize))
-  (set pixw (* (/ pixw 8) 7))
-  (local tilew (* self.sprite-scale pixw))
-  (local tileh (* self.sprite-scale pixh))
-  (for [itile 1 (length self.tilecache.tiles)]
-    (self:draw-sprite tilex tiley itile ?key)
-    (when (and (= itile self.itile) (= ?key self.tilekey))
-      (love.graphics.rectangle :line (- tilex 2) (- tiley 2) (+ tilew 4) (+ tileh 4)))
-    (when (button self [:tile itile] tilex tiley tilew tileh)
-      (set self.itile itile)
-      (set self.tilekey ?key))
-    (set tilex (+ tilex tilew 4))
-    (when (>= (+ tilex tilew) (+ x w))
-      (set tilex x)
-      (set tiley (+ tiley tileh 4))))
-  (+ tiley tileh (- y)))
+(fn tile-selector [{: view &as form} selected-itile ?key]
+  (var selected-itile selected-itile)
+  (let [g (group-wrapper form)
+        wrap (horiz-wrapper form)]
+    (for [itile 1 (length view.tilecache.tiles)]
+      (let [{: x : y} form
+            (w h) (view:draw-sprite x y itile ?key)]
+        (when (and w h)
+          (when (= itile selected-itile)
+            (love.graphics.rectangle :line (- x 2) (- y 2) (+ w 4) (+ h 4)))
+          (when (g button (reform form {:tag [:tile itile] : w : h}))
+            (set selected-itile itile))
+          (wrap form))))
+    (g)
+    selected-itile))
+
+(fn GraphicsEditView.draw-tile-selector [self form ?key]
+  (match (tile-selector (reform form {:scale self.sprite-scale :w form.w}) (when (= self.tilekey ?key) self.itile) ?key)
+    selected-itile (do (set self.itile selected-itile)
+                       (set self.tilekey ?key))))
 
 GraphicsEditView

editor/imgui.fnl

@@ -0,0 +1,389 @@
+(local core (require :core))
+(local config (require :core.config))
+(local command (require :core.command))
+(local keymap (require :core.keymap))
+(local style (require :core.style))
+(local lume (require :lib.lume))
+
+(fn attach-imstate [view]
+  (set view.imstate {})
+  (fn view.on_mouse_pressed [self button x y clicks]
+    (tset self.imstate button :pressed)
+    (self.__index.on_mouse_pressed self button x y clicks))
+  (fn view.on_mouse_released [self button x y]
+    (tset self.imstate button :released)
+    (self.__index.on_mouse_released self button x y))
+  (fn view.on_key_pressed [self key]
+    (when (= self.imstate.keys nil)
+      (set self.imstate.keys []))
+    (table.insert self.imstate.keys key))
+  (fn view.on_text_input [self text]
+    (set self.imstate.text (.. (or self.imstate.text "") text))
+    (self.__index.on_text_input self text))
+  (fn view.form [self ?overrides]
+    (lume.merge {:x (+ self.position.x style.padding.x (- self.scroll.x))
+                 :y (+ self.position.y style.padding.y (- self.scroll.y))
+                 :w (- self.size.x (* style.padding.x 2))
+                 :view self}
+                (or ?overrides {})))
+  (fn view.end-scroll [self {: y : h}]
+    (let [pin-to-bottom (>= self.scroll.to.y (- self.scrollheight self.size.y))]
+      (set self.scrollheight (- (+ y (or h 0) style.padding.y) (+ self.position.y style.padding.y (- self.scroll.y))))
+      (when pin-to-bottom (set self.scroll.to.y (- self.scrollheight self.size.y)))))
+  (fn view.draw [self]
+    (set self.cursor nil)
+    (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))
+    (set self.imstate.keys nil)
+    (set self.imstate.text nil)
+    (when (= self.imstate.left :released)
+      (set self.imstate.active nil))
+    (each [_ button (pairs [:left :middle :right])]
+      (tset self.imstate button
+        (match (. self.imstate button)
+          :pressed  :down
+          :down     :down
+          :released nil)))))
+
+(fn register-keys [keys]
+  (local commands {})
+  (local keymaps {})
+  (each [_ key (ipairs keys)]
+    (local command-name (.. "imstate:" key))
+    (tset commands command-name #(core.active_view:on_key_pressed key))
+    (tset keymaps key command-name))
+  (command.add #(not= (-?> core.active_view.imstate (. :focus)) nil) commands)
+  (keymap.add keymaps))
+
+(register-keys [:backspace :delete :left :right :shift+left :shift+right :home :end :shift+home :shift+end
+                :ctrl+left :ctrl+right :ctrl+shift+left :ctrl+shift+right :ctrl+c :ctrl+v])
+
+(fn cmd-predicate [p]
+  (var p-fn p)
+  (when (= (type p-fn) :string) (set p-fn (require p-fn)))
+  (when (= (type p-fn) :table)
+    (local cls p-fn)
+    (set p-fn (fn [] (core.active_view:is cls))))
+  (fn [] (when (= (-?> core.active_view.imstate (. :focus)) nil)
+           (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]
+  (match (type tag)
+    :string tag
+    :table  (table.concat tag "::")
+    _       (tostring tag)))
+
+(fn mouse-inside [x y w h]
+  (local (mx my) (values (love.mouse.getX) (love.mouse.getY)))
+  (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}]
+  (when (and (mouse-inside x y w h) (consume-pressed view :left))
+    (set view.imstate.active (make-tag tag))
+    true))
+
+(fn set-cursor [view cursor]
+  (when (= view.cursor nil) (set view.cursor cursor)))
+
+;; styling and layout
+(fn form-defaults [form k v ...]
+  (when (= (. form k) nil)
+    (let [v (if (= (type v) :function) (v form) v)]
+      (tset form k v)))
+  (if (>= (select :# ...) 2) (form-defaults form ...)
+    (do (when form.tag (set form.tag (make-tag form.tag))) ; fix up tag
+        form)))
+
+(fn with-style [form ...]
+  (form-defaults form :font style.font :color style.text :xpad style.padding.x :ypad style.padding.y ...))
+
+(local form-preserved-keys (collect [_ key (ipairs [:view :x :y :font :color :xpad :ypad])] key true))
+(fn reform [form overrides]
+  (if (and overrides overrides.into (not= overrides.into form))
+    (reform (lume.extend (lume.clear overrides.into) form) overrides)
+    (do (each [key (pairs form)]
+          (when (= (. form-preserved-keys key) nil)
+            (tset form key nil)))
+        (lume.extend form (or overrides {})))))
+
+(fn under [form overrides]    (reform form (lume.merge (or overrides {}) {:y (+ form.y (or form.h 0) (or form.ypad 0))})))
+(fn right-of [form overrides] (reform form (lume.merge (or overrides {}) {:x (+ form.x (or form.w 0) (or form.xpad 0))})))
+
+(fn group-wrapper [orig-form]
+  (let [group {}
+        update-dimension
+        (fn [form coord-key size-key]
+          (let [coord-group (. group coord-key) size-group (. group size-key)
+                coord-form (. form coord-key)   size-form (. form size-key)]
+            (if (= size-form nil) ; tried to add an unsized value to the group, ignore
+                nil
+
+                (= coord-group nil) ; container takes on the size of its first item
+                (do (tset group coord-key coord-form)
+                    (tset group size-key size-form))
+
+                (> coord-group coord-form) ; we have an item that is outside the bounds to the left / up; reduce the starting point and extend the size
+                (do (tset group coord-key coord-form)
+                    (tset group size-key (- (math.max (+ coord-form size-form) (+ coord-group size-group)) coord-form)))
+
+              ; extend the size if the new item is outside the bounds to the right / down
+              (tset group size-key (- (math.max (+ coord-form size-form) (+ coord-group size-group)) coord-group)))
+            form))
+        update-dimensions (fn [form] (update-dimension form :x :w) (update-dimension form :y :h))]
+
+    (fn [?viewfn-or-form ?form ...]
+      (match [(type ?viewfn-or-form) ?viewfn-or-form]
+        [:function viewfn] (let [result [(viewfn ?form ...)]]
+                             (update-dimensions ?form)
+                             (table.unpack result))
+        [:table form]      (update-dimensions form)
+        [:nil]             (lume.extend orig-form group)))))
+
+(fn horiz-wrapper [{:x orig-x :w orig-w}]
+  (fn [{: x : y : w : h : xpad : ypad &as form} overrides]
+    (if (> (+ x (or w 0) xpad (or w 0)) (+ orig-x orig-w))
+      (reform form (lume.merge (or overrides {}) {:x orig-x :y (+ y (or h 0) (or ypad 0))}))
+      (right-of form overrides))))
+
+;; widgets and widget helpers
+(fn active? [view tag] (= view.imstate.active (make-tag tag)))
+(fn button [{: view : tag : x : y : w : h &as form}]
+  (when (mouse-inside x y w h) (set-cursor view :hand))
+  (activate form)
+  (and (active? view tag) (= view.imstate.left :released) (mouse-inside x y w h)))
+
+(fn label [form text]
+  (let [(_ newlines) (text:gsub "\n" "\n")
+        text-height (fn [font] (* (font:get_height) (+ newlines 1)))
+        {: x : y : w : h : halign : valign : font : color}
+        (with-style form
+                    :w #($1.font:get_width text)
+                    :h #(text-height $1.font)
+                    :halign :left
+                    :valign :center)
+        x (match halign :left x :center (+ x (/ (- w (font:get_width text)) 2)) :right (+ x w (- (font:get_width text))))
+        y (match valign :top y :center (+ y (/ (- h (text-height font)) 2)) :bottom (+ y h (- (text-height font))))]
+    (renderer.draw_text font text x y color)))
+
+(fn textbutton [form label]
+  (let [{: x : y : w : h : xpad : ypad : font : color : bg}
+        (with-style form
+                    :bg style.selection
+                    :tag label
+                    :w #(+ ($1.font:get_width label) $1.xpad)
+                    :h #(+ ($1.font:get_height) $1.ypad))]
+    (renderer.draw_rect x y w h bg)
+    (renderer.draw_text font label (+ x (/ xpad 2)) (+ y (/ ypad 2)) color)
+    (button form)))
+
+(fn checkbox [form name isset]
+  (let [{: x : y : w : h : font : color : x-label}
+        (with-style form
+                    :tag name
+                    :h (* 12 SCALE)
+                    :x-label #(+ $1.x $1.h $1.xpad)
+                    :w #(+ $1.x-label ($1.font:get_width name)))]
+    (love.graphics.rectangle (if isset :fill :line) x y h h)
+    (renderer.draw_text font name x-label y color)
+    (love.graphics.setColor 1 1 1 1)
+    (button form))) ; whose idea was this?? should return (not isset) >:/
+
+(fn focused? [view tag] (= (make-tag tag) (-?> view.imstate.focus (. :tag))))
+(fn focus [{: view : tag : x : y : w : h &as form} opts]
+  (if (activate form)
+      (set view.imstate.focus
+        (doto (lume.clone (or opts {}))
+          (tset :tag (make-tag tag))))
+
+      (and (= view.imstate.left :released) (focused? view tag) (not (mouse-inside x y w h)))
+      (set view.imstate.focus nil))
+  (focused? view tag))
+
+  (local blink_period 0.8)
+(fn x-from-i [s i xLeft font]
+  (if (or (<= i 1) (= s "")) xLeft
+      (x-from-i (s:sub 2) (- i 1) (+ xLeft (font:get_width (s:sub 1 1))) font)))
+(fn i-from-x [s x xLeft font ?i]
+  (local i (or ?i 1))
+  (local w (font:get_width (s:sub 1 1)))
+  (local xMid (+ xLeft (/ w 2)))
+  (if (or (<= x xMid) (= s "")) i
+      (i-from-x (s:sub 2) x (+ xLeft w) font (+ i 1))))
+
+(fn next-match [text i di pred]
+  (local imax (+ (length text) 1))
+  (local inext (+ i di))
+  (if (<= inext 1) 1
+      (> inext imax) imax
+      (pred (text:sub inext inext)) (if (< di 0) i inext)
+    (next-match text inext di pred)))
+(fn is-nonword-char [char] (config.non_word_chars:find char nil true))
+(fn next-word [text i di]
+  (let [iwordboundary (next-match text i di #(is-nonword-char $1))]
+    (next-match text iwordboundary di #(not (is-nonword-char $1)))))
+
+(fn textnav [key i text]
+  (local imax (+ (length text) 1))
+  (match key
+    :left       (math.max 1 (- i 1))
+    :right      (math.min imax (+ i 1))
+    :ctrl+left  (next-word text i -1)
+    :ctrl+right (next-word text i 1)
+    :home       1
+    :end        imax))
+
+(fn selection-span [view]
+  (let [f       view.imstate.focus
+        iStart  (math.min f.i f.iAnchor)
+        iLim    (math.max f.i f.iAnchor)]
+    (values iStart iLim)))
+(fn selection-text [view text]
+  (local (iStart iLim) (selection-span view))
+  (text:sub iStart (- iLim 1)))
+
+(fn replace-selection [view s replacement ?iStart ?iLim]
+  (local (iStart iLim) (if ?iLim (values ?iStart ?iLim) (selection-span view)))
+  (local text
+    (.. (s:sub 1 (- iStart 1))
+        replacement
+        (s:sub iLim)))
+  (local iNew (+ iStart (length replacement)))
+  (set view.imstate.focus.i iNew)
+  (set view.imstate.focus.iAnchor iNew)
+  text)
+
+(fn textbox [form text]
+  (local {: font : color : w : h : x : y : xpad : ypad : color : view : tag}
+         (with-style form :h #(+ ($1.font:get_height) $1.ypad)))
+  (var textNew (or text ""))
+  (local (hText xText yText) (values (font:get_height) (+ x (/ xpad 2)) (+ y (/ ypad 2))))
+  (local initial-press (= view.imstate.left :pressed))
+
+  ; handle key events
+  (when (focus form {:i 1 :iAnchor 1 :blink (love.timer.getTime)})
+    (local f view.imstate.focus)
+    (when (> f.i (+ (length textNew) 1))       (set f.i (+ (length textNew) 1)))
+    (when (> f.iAnchor (+ (length textNew) 1)) (set f.iAnchor (+ (length textNew) 1)))
+    (when view.imstate.text
+      (set textNew (replace-selection view textNew view.imstate.text)))
+    (each [_ key (ipairs (or view.imstate.keys []))]
+      (set view.imstate.focus.blink (love.timer.getTime))
+      (if (= key :ctrl+c) (system.set_clipboard (selection-text view textNew))
+          (= key :ctrl+v) (set textNew (replace-selection view textNew (system.get_clipboard)))
+          (key:find "shift%+") (set f.i (or (textnav (key:gsub "shift%+" "") f.i textNew) f.i))
+        (let [iNav (textnav key f.i textNew)]
+          (when iNav
+            (set f.i iNav)
+            (set f.iAnchor iNav))
+          (when (or (= key :delete) (= key :backspace))
+            (local (iStartDel iLimDel)
+              (if (not= f.i f.iAnchor) (selection-span view)
+                  (= key :delete)      (values f.i (+ f.i 1))
+                  (= key :backspace)   (values (math.max 1 (- f.i 1)) f.i)))
+            (set textNew (replace-selection view textNew "" iStartDel iLimDel)))))))
+
+  ; handle mouse events
+  (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))
+    (local mouse-i (i-from-x textNew (love.mouse.getX) x style.font))
+    (when initial-press
+      (set view.imstate.focus.iAnchor mouse-i))
+    (set view.imstate.focus.i mouse-i))
+
+  ; draw box
+  (love.graphics.setLineWidth 1)
+  (love.graphics.rectangle :line x y w h)
+  (if (focused? view tag)
+    ; draw text with selection + caret
+    (let [(iStart iLim) (selection-span view)
+          xSelect (renderer.draw_text font (textNew:sub 1 (- iStart 1)) xText yText color)
+          sSelect (textNew:sub iStart (- iLim 1))
+          wSelect (font:get_width sSelect)
+          xTail   (+ xSelect wSelect)]
+      (when (> wSelect 0)
+        (renderer.draw_rect xSelect yText wSelect hText style.selection)
+        (renderer.draw_text font sSelect xSelect yText color))
+      (renderer.draw_text font (textNew:sub iLim) xTail yText color)
+      (when (or (active? view tag)
+                 (< (% (- (love.timer.getTime) view.imstate.focus.blink) (* blink_period 2)) blink_period))
+         (renderer.draw_rect (x-from-i textNew view.imstate.focus.i xText font) yText style.caret_width hText style.caret)))
+    ; just draw the text
+    (renderer.draw_text font textNew xText yText color))
+  (love.graphics.setColor 1 1 1)
+  textNew)
+
+(fn textfield [form label text]
+  (let [{: x : y : w : wlabel : wtext : font : color}
+        (with-style form :wlabel #(+ ($1.font:get_width label) $1.xpad)
+                         :wtext (* 150 SCALE)
+                         :w #(+ $1.wlabel $1.wtext)
+                         :tag label)
+        form-textbox (lume.merge form {:w wtext :x (+ x wlabel)})
+        _ (renderer.draw_text font label x y color)
+        text (textbox form-textbox text)]
+    (set form.h form-textbox.h)
+    text))
+
+(fn option-text [option]
+  (match (type option)
+    :string option
+    :table (or option.label (tostring option))
+    _ (tostring option)))
+
+(fn dropdown [form selection options]
+  (let [{: x : y : w :h row-h : font : color : bg : xpad : ypad : view : tag}
+        (with-style form :w (* 150 SCALE)
+                         :h #(+ ($1.font:get_height) $1.ypad)
+                         :bg style.selection)]
+    (var new-selection nil)
+
+    (renderer.draw_rect x y w row-h bg)
+    (renderer.draw_text style.font (option-text selection) (+ x xpad) (+ y (/ ypad 2)) color)
+    (renderer.draw_text style.icon_font "-" (+ x w (- xpad)) (+ y (/ ypad 2)) color)
+
+    (when (focused? view tag)
+      (var row-y (+ y row-h))
+      (each [i option (ipairs options)]
+        (when (button (lume.merge form {:tag [(make-tag tag) i] :y row-y}))
+          (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 bg)
+           (renderer.draw_text font (option-text option) (+ x xpad) (+ row-y (/ ypad 2)) color)
+         (set row-y (+ row-y row-h))))))
+    (focus form)
+    (or new-selection selection)))
+
+(fn labelled-dropdown [form label selection options]
+  (let [{: x : y : wlabel : wdropdown : font : color}
+        (with-style form :wlabel #(+ ($1.font:get_width label) $1.xpad)
+                         :wdropdown (* 150 SCALE)
+                         :w #(+ $1.wlabel $1.wdropdown)
+                         :tag label)
+        form-dropdown (lume.merge form {:x (+ x wlabel) :w wdropdown})
+        _ (renderer.draw_text font label x y color)
+        selection (dropdown form-dropdown selection options)]
+    (set form.h form-dropdown.h)
+    selection))
+
+{: attach-imstate : cmd-predicate : postpone : mouse-inside : activate : active?
+ : button : checkbox : textbox : textfield : textbutton : dropdown : labelled-dropdown : label
+ : reform : under : right-of : horiz-wrapper : group-wrapper
+ : with-style : form-defaults}
+

editor/imstate.fnl

@@ -1,267 +0,0 @@
-(local core (require :core))
-(local config (require :core.config))
-(local command (require :core.command))
-(local keymap (require :core.keymap))
-(local style (require :core.style))
-(local lume (require :lib.lume))
-
-(fn attach-imstate [view]
-  (set view.imstate {})
-  (fn view.on_mouse_pressed [self button x y clicks]
-    (tset self.imstate button :pressed)
-    (self.__index.on_mouse_pressed self button x y clicks))
-  (fn view.on_mouse_released [self button x y]
-    (tset self.imstate button :released)
-    (self.__index.on_mouse_released self button x y))
-  (fn view.on_key_pressed [self key]
-    (when (= self.imstate.keys nil)
-      (set self.imstate.keys []))
-    (table.insert self.imstate.keys key))
-  (fn view.on_text_input [self text]
-    (set self.imstate.text (.. (or self.imstate.text "") text))
-    (self.__index.on_text_input self text))
-  (fn view.draw [self]
-    (set self.cursor nil)
-    (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))
-    (set self.imstate.keys nil)
-    (set self.imstate.text nil)
-    (when (= self.imstate.left :released)
-      (set self.imstate.active nil))
-    (each [_ button (pairs [:left :middle :right])]
-      (tset self.imstate button
-        (match (. self.imstate button)
-          :pressed  :down
-          :down     :down
-          :released nil)))))
-
-(fn register-keys [keys]
-  (local commands {})
-  (local keymaps {})
-  (each [_ key (ipairs keys)]
-    (local command-name (.. "imstate:" key))
-    (tset commands command-name #(core.active_view:on_key_pressed key))
-    (tset keymaps key command-name))
-  (command.add #(not= (-?> core.active_view.imstate (. :focus)) nil) commands)
-  (keymap.add keymaps))
-
-(register-keys [:backspace :delete :left :right :shift+left :shift+right :home :end :shift+home :shift+end
-                :ctrl+left :ctrl+right :ctrl+shift+left :ctrl+shift+right :ctrl+c :ctrl+v])
-
-(fn cmd-predicate [p]
-  (var p-fn p)
-  (when (= (type p-fn) :string) (set p-fn (require p-fn)))
-  (when (= (type p-fn) :table)
-    (local cls p-fn)
-    (set p-fn (fn [] (core.active_view:is cls))))
-  (fn [] (when (= (-?> core.active_view.imstate (. :focus)) nil)
-           (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]
-  (match (type tag)
-    :string tag
-    :table  (table.concat tag "::")
-    _       (tostring tag)))
-
-(fn mouse-inside [x y w h]
-  (local (mx my) (values (love.mouse.getX) (love.mouse.getY)))
-  (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]
-  (when (and (mouse-inside x y w h) (consume-pressed view :left))
-    (set view.imstate.active (make-tag tag))
-    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 button [view tag x y w h]
-  (when (mouse-inside x y w h) (set-cursor view :hand))
-  (activate view tag 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 ?font]
-  (let [font (or ?font style.font)]
-    (local (w h) (values (+ (font:get_width label) style.padding.x) (+ (font:get_height) style.padding.y)))
-    (renderer.draw_rect x y w h style.selection)
-    (renderer.draw_text font label (+ x (/ style.padding.x 2)) (+ y (/ style.padding.y 2)) style.text)
-    (values (button view label x y w h) (+ y h))))
-
-(fn checkbox [view name isset x y ?tag]
-  (love.graphics.rectangle (if isset :fill :line) x y (* 12 SCALE) (* 12 SCALE))
-  (local xEnd (renderer.draw_text style.font name (+ x (* 16 SCALE)) y style.text))
-  (love.graphics.setColor 1 1 1 1)
-  (button view (or ?tag name) x y (- xEnd x) (* 12 SCALE)))
-
-(fn focused? [view tag] (= (make-tag tag) (-?> view.imstate.focus (. :tag))))
-(fn focus [view tag x y w h opts]
-  (if (activate view tag x y w h)
-      (set view.imstate.focus
-        (doto (lume.clone (or opts {}))
-          (tset :tag (make-tag tag))))
-
-      (and (= view.imstate.left :released) (focused? view tag) (not (mouse-inside x y w h)))
-      (set view.imstate.focus nil))
-  (focused? view tag))
-
-(local blink_period 0.8)
-(fn x-from-i [s i xLeft font]
-  (if (or (<= i 1) (= s "")) xLeft
-      (x-from-i (s:sub 2) (- i 1) (+ xLeft (font:get_width (s:sub 1 1))) font)))
-(fn i-from-x [s x xLeft font ?i]
-  (local i (or ?i 1))
-  (local w (font:get_width (s:sub 1 1)))
-  (local xMid (+ xLeft (/ w 2)))
-  (if (or (<= x xMid) (= s "")) i
-      (i-from-x (s:sub 2) x (+ xLeft w) font (+ i 1))))
-
-(fn next-match [text i di pred]
-  (local imax (+ (length text) 1))
-  (local inext (+ i di))
-  (if (<= inext 1) 1
-      (> inext imax) imax
-      (pred (text:sub inext inext)) (if (< di 0) i inext)
-    (next-match text inext di pred)))
-(fn is-nonword-char [char] (config.non_word_chars:find char nil true))
-(fn next-word [text i di]
-  (let [iwordboundary (next-match text i di #(is-nonword-char $1))]
-    (next-match text iwordboundary di #(not (is-nonword-char $1)))))
-
-(fn textnav [key i text]
-  (local imax (+ (length text) 1))
-  (match key
-    :left       (math.max 1 (- i 1))
-    :right      (math.min imax (+ i 1))
-    :ctrl+left  (next-word text i -1)
-    :ctrl+right (next-word text i 1)
-    :home       1
-    :end        imax))
-
-(fn selection-span [view]
-  (let [f       view.imstate.focus
-        iStart  (math.min f.i f.iAnchor)
-        iLim    (math.max f.i f.iAnchor)]
-    (values iStart iLim)))
-(fn selection-text [view text]
-  (local (iStart iLim) (selection-span view))
-  (text:sub iStart (- iLim 1)))
-
-(fn replace-selection [view s replacement ?iStart ?iLim]
-  (local (iStart iLim) (if ?iLim (values ?iStart ?iLim) (selection-span view)))
-  (local text
-    (.. (s:sub 1 (- iStart 1))
-        replacement
-        (s:sub iLim)))
-  (local iNew (+ iStart (length replacement)))
-  (set view.imstate.focus.i iNew)
-  (set view.imstate.focus.iAnchor iNew)
-  text)
-
-(fn textbox [view tag text x y w]
-  (var textNew (or text ""))
-  (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
-  (when (focus view tag x y w h {:i 1 :iAnchor 1 :blink (love.timer.getTime)})
-    (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
-      (set textNew (replace-selection view textNew view.imstate.text)))
-    (each [_ key (ipairs (or view.imstate.keys []))]
-      (set view.imstate.focus.blink (love.timer.getTime))
-      (if (= key :ctrl+c) (system.set_clipboard (selection-text view textNew))
-          (= key :ctrl+v) (set textNew (replace-selection view textNew (system.get_clipboard)))
-          (key:find "shift%+") (set f.i (or (textnav (key:gsub "shift%+" "") f.i textNew) f.i))
-        (let [iNav (textnav key f.i textNew)]
-          (when iNav
-            (set f.i iNav)
-            (set f.iAnchor iNav))
-          (when (or (= key :delete) (= key :backspace))
-            (local (iStartDel iLimDel)
-              (if (not= f.i f.iAnchor) (selection-span view)
-                  (= key :delete)      (values f.i (+ f.i 1))
-                  (= key :backspace)   (values (math.max 1 (- f.i 1)) f.i)))
-            (set textNew (replace-selection view textNew "" iStartDel iLimDel)))))))
-
-  ; handle mouse events
-  (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))
-    (local mouse-i (i-from-x textNew (love.mouse.getX) x style.font))
-    (when initial-press
-      (set view.imstate.focus.iAnchor mouse-i))
-    (set view.imstate.focus.i mouse-i))
-
-  ; draw box
-  (love.graphics.setLineWidth 1)
-  (love.graphics.rectangle :line x y w h)
-  (if (focused? view tag)
-    ; draw text with selection + caret
-    (let [(iStart iLim) (selection-span view)
-          xSelect (renderer.draw_text style.font (textNew:sub 1 (- iStart 1)) xText yText style.text)
-          sSelect (textNew:sub iStart (- iLim 1))
-          wSelect (style.font:get_width sSelect)
-          xTail   (+ xSelect wSelect)]
-      (when (> wSelect 0)
-        (renderer.draw_rect xSelect yText wSelect hText style.selection)
-        (renderer.draw_text style.font sSelect xSelect yText style.text))
-      (renderer.draw_text style.font (textNew:sub iLim) xTail yText style.text)
-      (when (or (active? view tag)
-                 (< (% (- (love.timer.getTime) view.imstate.focus.blink) (* blink_period 2)) blink_period))
-         (renderer.draw_rect (x-from-i textNew view.imstate.focus.i xText style.font) yText style.caret_width hText style.caret)))
-    ; just draw the text
-    (renderer.draw_text style.font textNew xText yText style.text))
-  (love.graphics.setColor 1 1 1)
-  (values textNew (+ y h)))
-
-(fn textfield [view label text x y wLabel wText]
-  (renderer.draw_text style.font label x y style.text)
-  (textbox view label text (+ x wLabel) y wText))
-
-(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}

editor/init.fnl

@@ -3,7 +3,7 @@
 (local MapEditView (require :editor.mapedit))
 (local ScreenEditView (require :editor.screenedit))
 (local PortraitView (require :editor.portraitedit))
-(local {: cmd-predicate} (util.require :editor.imstate))
+(local {: cmd-predicate} (util.require :editor.imgui))
 (local core (require :core))
 (local command (require :core.command))
 (local keymap (require :core.keymap))
@@ -43,6 +43,7 @@
   "graphics-editor:next-tile"     #(core.active_view:select-rel 1)
   "graphics-editor:previous-tile" #(core.active_view:select-rel -1)
 })
+
 (command.add (cmd-predicate :editor.tileedit) {
   "tileedit:copy"
   #(system.set_clipboard (: (core.active_view:tile) :tohex))

editor/mapedit.fnl

@@ -3,45 +3,68 @@
 (local util (require :lib.util))
 (local lume (require :lib.lume))
 (local files (require :game.files))
-(local {: mouse-inside : activate : active? : checkbox : textfield : textbutton : textbox : dropdown} (util.require :editor.imstate))
+(local {: show} (util.require :inspector.debug))
+(local {: mouse-inside : activate : active? : checkbox : textfield : textbutton : textbox : dropdown : labelled-dropdown : under : right-of : reform : group-wrapper} (util.require :editor.imgui))
 (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 : dimensions} (util.require :game.tiles))
 (local actions (require :editor.actions))
 
 (local MapEditView (GraphicsEditView:extend))
 (local sprite-scale 3)
-(local mapw 20)
-(local maph 12)
-(local tilew (* sprite-scale 14))
-(local tileh (* sprite-scale 16))
+
+(fn platform [?key] (let [p (dimensions)] (if ?key (. p ?key) p)))
+(fn MapEditView.layer [self ?ilayer] (or (?. (platform :layers) (or ?ilayer self.ilayer)) {:style :tiles}))
+(fn MapEditView.layer-type [self ?ilayer] (. (self:layer ?ilayer) :style))
+(fn MapEditView.layer-offset [self ?ilayer] (let [{: x : y} (self:layer ?ilayer)] [(* sprite-scale (or x 0)) (* sprite-scale (or y 0))]))
+(fn MapEditView.dimensions [self ?ilayer] (or (platform (self:layer-type ?ilayer)) (platform)))
+(fn MapEditView.scaled-dimensions [self ?ilayer]
+  (let [dim (lume.clone (self:dimensions ?ilayer))]
+    (each [_ key (ipairs [:tilew :tileh :xstagger :ystagger])]
+      (when (. dim key) (tset dim key (* sprite-scale (. dim key)))))
+    dim))
+
+(fn MapEditView.mapw [self ?ilayer] (. (self:dimensions ?ilayer) :mapw))
+(fn MapEditView.maph [self ?ilayer] (. (self:dimensions ?ilayer) :maph))
+(fn MapEditView.tilew [self ?ilayer] (. (self:scaled-dimensions ?ilayer) :tilew))
+(fn MapEditView.tileh [self ?ilayer] (. (self:scaled-dimensions ?ilayer) :tileh))
+
+(fn MapEditView.empty-map [self ?ilayer] (string.rep "\0" (* (self:mapw ?ilayer) (self:maph ?ilayer))))
 
 (fn MapEditView.new [self]
   (MapEditView.super.new self)
   (set self.sprite-scale sprite-scale)
   (set self.stripcache {})
   (set self.ilevel 1)
+  (self:set-ilayer 1)
   (self:reload))
 
 ; map is stored bottom-to-top
-(fn imap-from-xy [mx my]
-  (+ mx -1 (* mapw (- maph my))))
+(fn MapEditView.imap-from-xy [self mx my ?ilayer]
+  (+ mx -1 (* (self:mapw ?ilayer) (- (self:maph ?ilayer) my))))
 
-(fn update-map [map mx my itile]
-  (local imap (imap-from-xy mx my))
+(fn MapEditView.update-map [self map mx my itile]
+  (local imap (self:imap-from-xy mx my))
   (local enctile (encode-itile itile))
   (..
     (map:sub 1 imap)
     (string.char enctile)
     (map:sub (+ imap 2))))
 
-(fn MapEditView.itile-from-xy [self mx my]
-  (local imap (+ (imap-from-xy mx my) 1))
-  (local enctile (string.byte (self.level.map:sub imap imap)))
+(fn MapEditView.map [self ?ilayer]
+  (if (platform :layers) (or (?. self.level.layers (or ?ilayer self.ilayer)) (self:empty-map ?ilayer))
+    self.level.map))
+
+(fn MapEditView.itile-from-xy [self mx my ?ilayer]
+  (local imap (+ (self:imap-from-xy mx my ?ilayer) 1))
+  (local enctile (or (string.byte (string.sub (self:map ?ilayer) imap imap)) 0))
   (decode-itile enctile))
 
 (fn MapEditView.set-tile [self mx my itile]
-  (set self.level.map (update-map self.level.map mx my itile)))
+  (let [updated-map (self:update-map (self:map) mx my itile)]
+    (if (platform :layers) (util.nested-tset self.level [:layers self.ilayer] updated-map)
+      (set self.level.map updated-map))))
 
+; todo: objects exist on layers
 (fn MapEditView.iobject-from-xy [self mx my ?iobj]
   (local iobj (or ?iobj 1))
   (local obj (. self.level.objects iobj))
@@ -60,23 +83,36 @@
   (when (. objects (+ iobjectsrc 1))
     (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 SCALE)) y (* 100 SCALE))]
+(fn MapEditView.levels [self]
+  (when (= files.game.levels nil)
+    (set files.game.levels []))
+  files.game.levels)
+
+(fn MapEditView.draw-map-selector [self form]
+  (let [level-count (length (self:levels))
+        options (icollect [i (util.countiter (+ level-count 1))] (if (<= i level-count) i :New))
+        ilevel (labelled-dropdown (reform form {:tag :map-selector :wdropdown (* 100 SCALE)}) "Map" self.ilevel options)]
     (when (not= ilevel self.ilevel)
       (set self.ilevel (if (= ilevel :New) (+ level-count 1) ilevel))
-      (self:load-level))
-    (- yNext y)))
+      (self:load-level))))
+
+(fn MapEditView.set-ilayer [self ilayer]
+  (set self.ilayer ilayer)
+  (self:set-style (self:layer-type)))
+
+(fn MapEditView.draw-layer-selector [self {: x : y &as form}]
+  (let [mkopt (fn [ilayer] {: ilayer :label (.. ilayer " (" (self:layer-type ilayer) ")")})
+        options (icollect [ilayer (ipairs (platform :layers))] (mkopt ilayer))
+        selection (labelled-dropdown (reform form {:wdropdown (* 100 SCALE) :tag :layer-selector}) "Layer" (mkopt self.ilayer) options)]
+    (when (not= self.ilayer selection.ilayer)
+      (self:set-ilayer selection.ilayer))))
 
 (fn MapEditView.linking-obj [self] (. self.level.objects self.iobject-linking))
 (fn MapEditView.draw-link-line [self x y iobjectSrc color toMouse?]
   (local objectSrc (. self.level.objects iobjectSrc))
   (local objectDest (. self.level.objects objectSrc.link))
   (local coord (fn [c m d] (+ c (* (- m 1) d) (/ d 2))))
+  (local [tilew tileh] [(self:tilew) (self:tileh)])
   (local xStart (coord x objectSrc.x tilew))
   (local yStart (coord y objectSrc.y tileh))
   (when (or toMouse? objectDest)
@@ -87,54 +123,60 @@
     (love.graphics.circle :line xEnd yEnd (/ tilew 5))
     (love.graphics.setColor 1 1 1)))
 
-(fn MapEditView.draw-tilestrip [self x y my]
+(fn MapEditView.draw-link-lines [self {: x : y} iobject-over]
+    (for [iobject 1 (length self.level.objects)]
+      (self:draw-link-line x y iobject [0 0 1 0.3]))
+    (when (not= iobject-over nil) (self:draw-link-line x y iobject-over [0 0.5 1] false))
+    (when (not= 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))))
+
+(fn MapEditView.draw-tilestrip [self x y my ?ilayer translucent?]
   ; stripcache leaks but honestly who cares
   (local tilestrip [])
-  (var stripid "")
-  (for [mx 1 mapw]
-    (local itile (self:itile-from-xy mx my))
-    (local tile (?. self.tilecache.tiles itile :gfx))
+  (var stripid (tostring ?ilayer))
+  (for [mx 1 (self:mapw ?ilayer)]
+    (local itile (self:itile-from-xy mx my ?ilayer))
+    (local tile (?. (files.cache (self:layer-type ?ilayer)) :tiles itile :gfx))
     (table.insert tilestrip tile)
     (set stripid (.. stripid  (string.char itile))))
   (var sprite (. self.stripcache stripid))
   (when (= sprite nil)
-    (set sprite (tilestrip-to-sprite tilestrip))
+    (set sprite (tilestrip-to-sprite tilestrip (self:layer-type ?ilayer)))
     (tset self.stripcache stripid sprite))
+  (love.graphics.setColor 1 1 1 (if translucent? 0.4 1))
   (love.graphics.draw sprite x y 0 self.sprite-scale self.sprite-scale))
 
-(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]
-    (local tiley (+ y (* (- my 1) tileh)))
-    (self:draw-tilestrip x tiley my)
-    (for [mx 1 mapw]
-      (local tilex (+ x (* (- mx 1) tilew)))
-      (local itile (self:itile-from-xy mx my))
-      (local iobject (self:iobject-from-xy mx my))
-      (when (= self.itile nil)
-        (each [_ player (ipairs (or files.game.players [:player]))]
-          (match (. self.level player)
-            {:x mx :y my} (renderer.draw_text style.font player tilex tiley style.text)))
-        (love.graphics.setColor 1 1 1))
-      (when (and (not= iobject nil) (= self.itile nil))
-        (love.graphics.setColor 1 0 (if (and (= self.itile nil) (= iobject self.iobject)) 1 0))
-        (love.graphics.setLineWidth 3)
-        (love.graphics.rectangle :line tilex tiley tilew tileh)
-        (love.graphics.setColor 1 1 1))
-      (when (mouse-inside tilex tiley tilew tileh)
-        (when (not= iobject nil) (set iobject-over iobject))
-        (renderer.draw_text style.font (string.format "%x" (encode-yx {:x mx :y my})) tilex (+ tiley 15) style.text)
-        (love.graphics.setColor 1 1 1))
-      (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 button-state
-          :pressed (set self.iobject-linking iobject)
-          :released
-          (if (and (not= iobject nil) (= self.iobject-linking iobject))
+(fn MapEditView.mapsize [self ilayer]
+  (let [{: mapw : maph : tilew : tileh : xstagger : ystagger} (self:scaled-dimensions ilayer)
+        intileh (or ystagger tileh)]
+    [(+ (or xstagger 0) (* mapw tilew)) (+ tileh (* (- maph 1) intileh))]))
+
+(fn MapEditView.draw-player [self mx my x y]
+  (each [_ player (ipairs (or files.game.players [:player]))]
+    (match (. self.level player)
+      {:x mx :y my} (renderer.draw_text style.font player x y style.text)))
+  (love.graphics.setColor 1 1 1))
+
+(fn MapEditView.draw-box [self x y w h color thickness]
+  (love.graphics.setColor (table.unpack color))
+  (love.graphics.setLineWidth thickness)
+  (love.graphics.rectangle :line x y w h)
+  (love.graphics.setColor 1 1 1))
+
+
+(fn MapEditView.draw-object-box [self x y w h iobject]
+  (when iobject
+    (let [color [1 0 (if (and (= self.itile nil) (= iobject self.iobject)) 1 0) 1]]
+      (self:draw-object-box x y w h color 3))))
+
+(fn MapEditView.handle-mouseedits-object [self mx my x y w h ilayer]
+  (when (and (active? self [:map ilayer]) (mouse-inside x y w h))
+    (let [iobject (self:iobject-from-xy mx my)]
+      (match self.imstate.left
+        :down (when (= self.iobject-linking nil) (set self.iobject-linking iobject))
+        :released
+        (do (if (and (not= iobject nil) (= self.iobject-linking iobject))
               (set self.iobject iobject)
 
               (not= self.iobject-linking nil)
@@ -145,16 +187,61 @@
                   (set self.playerpos nil))
 
               (= iobject nil)
-              (let [tile (self.tilecache:tile itile)]
+              (let [tile (self.tilecache:tile (self:itile-from-xy mx my ilayer))]
                 (table.insert self.level.objects {:x mx :y my :func (or tile.word "")})
-                (set self.iobject (length self.level.objects))))))))
-  (when (= self.itile nil)
-    (for [iobject 1 (length self.level.objects)]
-      (self:draw-link-line x y iobject [0 0 1 0.3]))
-    (when (not= iobject-over nil) (self:draw-link-line x y iobject-over [0 0.5 1] false))
-    (when (not= 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)))))
+                (set self.iobject (length self.level.objects))))
+            (set self.iobject-linking nil))))))
+
+(fn MapEditView.handle-mouseedits-tile [self mx my x y w h ilayer]
+  (when (and (active? self [:map ilayer]) (mouse-inside x y w h) (not= (self:itile-from-xy mx my ilayer) self.itile))
+    (self:set-tile mx my self.itile)))
+
+(fn MapEditView.draw-tile-xy-label [self mx my x y h ystagger]
+  (local labely (math.floor (+ y (- (or ystagger 0)) (/ (- (if ystagger (* ystagger 2) h) (style.font:get_height)) 2))))
+  (renderer.draw_text style.font (string.format "%x" (encode-yx {:x mx :y my})) (+ x 20) labely style.text)
+  (love.graphics.setColor 1 1 1))
+
+(fn MapEditView.draw-map-layer [self {: x : y &as form} live ilayer]
+  (love.graphics.setColor 1 1 1 1)
+  (local {: mapw : maph : tilew : tileh : xstagger : ystagger} (self:scaled-dimensions ilayer))
+  (local [xoffset-layer yoffset-layer] (self:layer-offset ilayer))
+  (local intileh (or ystagger tileh))
+  (let [[w h] (self:mapsize ilayer)] (lume.extend form {: w : h :tag [:map ilayer]}))
+  (when live (activate form))
+  (var iobject-over nil)
+  (for [my 1 maph]
+    (local tiley (+ y yoffset-layer (* (- my 1) (or ystagger tileh))))
+    (local intiley (+ tiley (- tileh intileh)))
+    (local xoff (+ xoffset-layer (if (and xstagger (= (% my 2) 0)) xstagger 0)))
+    (self:draw-tilestrip (+ x xoff) tiley my ilayer (and (mouse-inside x y form.w form.h) (not live)))
+    (when live
+      (for [mx 1 mapw]
+        (local tilex (+ x (* (- mx 1) tilew) xoff))
+        (local iobject (self:iobject-from-xy mx my))
+        (when (= self.itile nil)
+          (self:draw-player mx my tilex intiley)
+          (self:draw-object-box tilex intiley tilew intileh iobject))
+        (if self.itile
+          (self:handle-mouseedits-tile mx my tilex intiley tilew intileh ilayer)
+          (self:handle-mouseedits-object mx my tilex intiley tilew intileh ilayer))
+        (when (mouse-inside tilex intiley tilew intileh)
+          (when (not= iobject nil) (set iobject-over iobject))
+          (self:draw-tile-xy-label mx my tilex intiley tileh ystagger)
+          (self:draw-box tilex intiley tilew intileh [1 1 1 0.5] 1)))))
+  (when (and live (= self.itile nil))
+    (self:draw-link-lines form iobject-over)))
+
+(fn MapEditView.draw-map-editor [self form]
+  (let [g (group-wrapper form)
+        layers (platform :layers)]
+    (if layers
+        (do (each [ilayer (ipairs (platform :layers))]
+              (self:draw-map-layer (g) (= ilayer self.ilayer) ilayer))
+            (let [{: x : y : w : h} (g)]
+              (when (mouse-inside x y w h)
+                (self:draw-map-layer form true self.ilayer))))
+        (self:draw-map-layer form true))
+    (g)))
 
 (fn condition-label [flag]
   (if flag {:label flag : flag} {:label "<always>"}))
@@ -165,23 +252,19 @@
       (table.insert options (condition-label flag)))
     options))
 
-(fn MapEditView.draw-object-code-editor [self object x y]
-  (var y y)
+(fn MapEditView.draw-object-code-editor [self form object]
   (var istep-to-delete nil)
   (when (not object.steps) (set object.steps []))
   (each [istep step (ipairs object.steps)]
-    (when (textbutton self "X" (+ x (* 280 SCALE)) y)
+    (when (textbutton (reform form {:x (+ form.x (* 280 SCALE)) :into {}}) "X")
       (set istep-to-delete istep))
-    (set step.condition (. (dropdown self [:code-condition istep] (condition-label step.condition) (condition-options)
-                                     (+ x (* 100 SCALE) style.padding.x) y (* 100 SCALE))
-                           :flag))
-    (set (step.action y) (dropdown self [:code-action istep] (or step.action (. actions.actionlist 1)) actions.actionlist x y (* 100 SCALE)))
-    (set y (actions.edit step self x y (* 300 SCALE) istep))
-    (set y (+ y style.padding.y)))
+    (set step.condition (. (dropdown (reform form {:x (+ form.x (* 150 SCALE)) :w (* 100 SCALE) :tag [:code-condition istep] :into {}}) (condition-label step.condition) (condition-options)) :flag))
+    (set step.action (dropdown (reform form {:w (* 100 SCALE) :tag [:code-action istep]}) (or step.action (. actions.actionlist 1)) actions.actionlist))
+    (actions.edit step (under form {:w (* 300 SCALE)}) istep)
+    (under form))
   (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))
+  (when (textbutton (under form) "+ New Step")
+    (table.insert object.steps {})))
 
 (fn advanced? [object]
   (or object.advanced
@@ -189,42 +272,41 @@
            (not= object.func "")
            (not= object.func nil))))
 
-(fn MapEditView.draw-object-advanced-editor [self object x y]
-  (let [(func y) (textfield self "Word" object.func x y (* 100 SCALE) (* 200 SCALE))
-        (name y) (textfield self "Name" object.name x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE))
-        (linkword y) (textfield self "Link word" object.linkword x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE))
-        (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 SCALE) (* 200 SCALE)))]
-    (lume.extend object {: func : name : linkword : linkentity})
-    (when do-unlink (set object.link nil))
-    y))
+(fn MapEditView.draw-object-advanced-editor [self form object]
+  (let [fieldform {:wlabel (* 100 SCALE) :wtext (* 200 SCALE)}]
+    (set object.func (textfield (reform form fieldform) "Word" object.func))
+    (set object.name (textfield (under form fieldform) "Name" object.name))
+    (set object.linkword (textfield (under form fieldform) "Link word" object.linkword))
+    (if object.link
+      (when (textbutton (under form) "Unlink")
+        (set object.link nil))
+      (set object.linkentity (textfield (under form fieldform) "Link entity" object.linkentity)))))
 
-(fn MapEditView.draw-object-editor [self x y]
+(fn MapEditView.draw-object-editor [self form]
   (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 SCALE))
-        (mk-new-flag y) (textbutton self "+ New Flag" (+ x (* 200 SCALE) style.padding.x) (+ y style.padding.y))
-        do-delete (textbutton self "Delete" x (+ y (* style.padding.y 2)))
-        (do-advanced y) (textbutton self (if (advanced? object) "Simple" "Advanced") (+ x (* 150 SCALE)) (+ y (* style.padding.y 2)))]
-    (set self.new-flag-name new-flag-name)
-    (when mk-new-flag
+        footer (group-wrapper form)]
+    (if (advanced? object)
+      (self:draw-object-advanced-editor form object)
+      (self:draw-object-code-editor form object))
+    (set self.new-flag-name (footer textbox (under form {:tag :new-flag-name :w (* 200 SCALE)}) self.new-flag-name))
+
+    (when (footer textbutton (right-of form) "+ New Flag")
       (when (= files.game.flags nil)
         (set files.game.flags []))
-      (table.insert files.game.flags new-flag-name)
+      (table.insert files.game.flags self.new-flag-name)
       (set self.new-flag-name ""))
-    (when do-delete
+    (when (footer textbutton (under (footer)) "Delete")
       (move-object self.level.objects (+ self.iobject 1) self.iobject)
       (set self.iobject nil))
-    (when do-advanced (set object.advanced (not (advanced? object))))
-    y))
+    (when (footer textbutton (right-of form) (if (advanced? object) "Simple" "Advanced"))
+      (set object.advanced (not (advanced? object))))
+    (footer)))
 
 (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))
+  (when (= (. (self:levels) self.ilevel) nil)
+    (tset (self:levels) self.ilevel {:map (self:empty-map) :objects []}))
+  (set self.level (. (self:levels) self.ilevel))
   (set self.iobject nil))
 
 (fn MapEditView.reload [self]
@@ -232,42 +314,36 @@
   (self:load-level))
 
 (fn MapEditView.draw [self]
-  (var x (+ self.position.x style.padding.x (- self.scroll.x)))
-  (var y (+ self.position.y style.padding.y (- self.scroll.y)))
   (self:draw_background style.background)
   (self:draw_scrollbar)
-  (local ytop y)
-  (local editor-on-side (> self.size.x (+ (* tilew mapw) (* 300 SCALE))))
-  (set y (+ y (self:draw-map-selector x y) style.padding.y))
-  (self:draw-map-editor x y)
-  (set y (+ y (* tileh maph) style.padding.y))
-  (set y (+ y (self:draw-tile-selector x y (if editor-on-side (* tilew mapw)
-                                             (- self.size.x (* style.padding.x 2))))))
-
-  (set (self.level.tickword y) (textfield self "Tick word" self.level.tickword x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE)))
-  (set (self.level.moveword y) (textfield self "Move word" self.level.moveword x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE)))
-  (set (self.level.loadword y) (textfield self "Load word" self.level.loadword x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE)))
-  (let [(checked y-new) (checkbox self "Edit objects" (= self.itile nil) x (+ y style.padding.y))
-        _ (when checked
-            (set self.itile nil)
-            (set self.playerpos nil))]
-    (set y y-new)
+  (let [form (self:form)
+        form-editor (self:form)
+        header (group-wrapper form)
+        _ (header #(self:draw-map-selector $...) form)
+        _ (when (platform :layers) (header #(self:draw-layer-selector $...) (right-of form)))
+        _ (self:draw-map-editor (under (header)))
+        editor-on-side (> self.size.x (+ form.w (* 300 SCALE)))
+        fieldform {:wlabel (* 100 SCALE) :wtext (* 200 SCALE)}]
+    (when editor-on-side
+      (set form-editor.x (+ form.x form.w style.padding.x))
+      (set form-editor.w (- form-editor.w form.w style.padding.x)))
+    (self:draw-tile-selector (under form {:w (if editor-on-side form.w (- self.size.x (* style.padding.x 2)))}))
+    (set self.level.tickword (textfield (under form fieldform) "Tick word" self.level.tickword))
+    (set self.level.moveword (textfield (under form fieldform) "Move word" self.level.moveword))
+    (set self.level.loadword (textfield (under form fieldform) "Load word" self.level.loadword))
+    (when (checkbox (under form) "Edit objects" (= self.itile nil))
+      (set self.itile nil)
+      (set self.playerpos nil))
     (each [_ player (ipairs (or files.game.players [:player]))]
-      (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.playerpos player))
-        (set y y-new))))
-  (each [_ levelflag (ipairs (or files.game.levelflags []))]
-    (let [(checked y-new) (checkbox self levelflag (. self.level levelflag) x (+ y style.padding.y))]
-      (when checked (tset self.level levelflag (not (. self.level levelflag))))
-      (set y y-new)))
-  (when self.iobject
-    (set y (math.max y (if editor-on-side
-                         (self:draw-object-editor (+ x (* tilew mapw) style.padding.x) ytop)
-                         (self:draw-object-editor x (+ y style.padding.y))))))
-
-  (set self.scrollheight (+ y (- self.position.y) self.scroll.y style.padding.y)))
+      (when (checkbox (under form) (.. "Position " player) (and (= self.itile nil) (= self.playerpos player)))
+        (set self.itile nil)
+        (set self.playerpos player)))
+    (each [_ levelflag (ipairs (or files.game.levelflags []))]
+      (when (checkbox (under form) levelflag (. self.level levelflag))
+        (tset self.level levelflag (not (. self.level levelflag)))))
+    (when (not editor-on-side) (set form-editor.y (+ form.y form.h style.padding.y)))
+    (when self.iobject (self:draw-object-editor form-editor))
+    (self:end-scroll (if (> (+ form.y form.h) (+ form-editor.y (or form-editor.h 0))) form form-editor))))
 
 (fn MapEditView.get_name [self] (.. "Map " self.ilevel))
 

editor/portraitedit.fnl

@@ -2,27 +2,16 @@
 (local TileView (require :editor.tileedit))
 (local tiledraw (require :editor.tiledraw))
 (local tiles (require :game.tiles))
-(local {: textfield} (util.require :editor.imstate))
+(local {: textfield} (util.require :editor.imgui))
 
 (local PortraitView (TileView:extend))
 
-(fn PortraitView.tilesize [self] (values 32 32))
 (fn PortraitView.tilekeys [self] [:gfx])
-(fn PortraitView.resource-key [self] :portraits)
-(fn PortraitView.map-bitxy [self x y]
-  (local quadrant (+ (if (>= x 16) 2 0) (if (>= y 16) 1 0)))
-  (local tilex
-    (if (or (= x 0) (= x 30))  0
-        (or (= x 1) (= x 31))  15
-        (< x 16)               (- x 1)
-                               (- x 15)))
-  (local tiley (% y 16))
-  (local (ibyte ibit) (PortraitView.super.map-bitxy self tilex tiley))
-  (values (+ ibyte (* quadrant 32)) ibit))
-(fn PortraitView.draw-tile-flags [self x y]
+(fn PortraitView.initial-style [self] :portraits)
+(fn PortraitView.draw-sidebar [self form]
   (local tile (-?> self.tilecache.tiles (. self.itile)))
   (when tile
-    (set tile.label (textfield self "Label" tile.label x (+ y 4) 100 200))))
+    (set tile.label (textfield form "Label" tile.label))))
 
 (fn PortraitView.get_name [self] "Portrait Editor")
 

editor/repl.fnl

@@ -2,23 +2,22 @@
 (local fennel (require :lib.fennel))
 (local style (require :core.style))
 (local lume (require :lib.lume))
-(local {: textbutton} (util.require :editor.imstate))
+(local {: textbutton : under : group-wrapper} (util.require :editor.imgui))
 (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.inspector [{: w &as form} {: vals : states}]
+  (let [g (group-wrapper form)]
+    (each [i v (ipairs vals)]
+      (g #(inspect $...) (under (g) {: w}) (. states i) v))
+    (g)))
 
 (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)] {})})
+  {:draw repl.inspector : vals :states (icollect [_ (ipairs vals)] {})})
 
 (fn repl.run [{: listeners}]
   (fennel.repl {:readChunk coroutine.yield

editor/replview.fnl

@@ -1,5 +1,5 @@
 (local util (require :lib.util))
-(local {: attach-imstate : textbox} (util.require :editor.imstate))
+(local {: attach-imstate : textbox : textbutton : label : under : reform : group-wrapper : mouse-inside} (util.require :editor.imgui))
 (local View (require :core.view))
 (local style (require :core.style))
 
@@ -13,6 +13,7 @@
   (set self.cmd "")
   (set self.scrollheight math.huge)
   (set self.scrollable true)
+  (set self.title "REPL")
   (self.conn:listen self))
 
 (fn ReplView.try_close [self do_close]
@@ -24,38 +25,36 @@
 (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.draw-cmd [{: x : y : w : view &as form} {: cmd} iline]
+  (label form cmd)
+  (when (mouse-inside x y w form.h)
+    (when (textbutton (reform form {:x (+ x w -35) :into {}}) :X)
+      (table.remove view.log iline)
+      (table.remove view.log iline))
+    (when (textbutton (reform form {:x (+ x w -60) :into {}}) :!)
+      (view:submit cmd))))
 
 (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: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)
+  (let [{: w &as form} (self:form)
+        g (group-wrapper form)]
+    ; 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)]
+      (g line.draw (under (g) {: w}) line i))
+    (set self.cmd (g textbox (under (g) {: w :tag :command}) self.cmd))
+    (self:end-scroll (g))))
 
-  ; 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))))
+(fn ReplView.get_name [self] self.title)
 
 ReplView
 

editor/screenedit.fnl

@@ -3,7 +3,7 @@
 (local lume (require :lib.lume))
 (local style (require :core.style))
 (local {: char-to-sprite : scanline-to-sprite : screen-y-to-offset} (util.require :editor.tiledraw))
-(local {: mouse-inside : activate : active? : checkbox : textfield : textbutton} (util.require :editor.imstate))
+(local {: mouse-inside : activate : active?} (util.require :editor.imgui))
 
 (local ScreenEditView (GraphicsEditView:extend))
 (local screen-scale 4)
@@ -54,7 +54,7 @@
 
 (fn ScreenEditView.draw-screen-editor [self x y]
   (local (w h) (values (* screenw screen-scale) (* screenh screen-scale)))
-  (activate self :screen x y w h)
+  (activate {:view self :tag :screen : x : y : w : h})
   (var screen self.screen)
   (when (and self.itile (mouse-inside x y w h))
     (local mx (math.floor (/ (- (love.mouse.getX) x) screen-scale)))

editor/tiledraw/ii.fnl

@@ -1,3 +1,5 @@
+(local {: putpixel : make-canvas} (require :editor.tiledraw))
+
 (fn pal-from-bit [bit]
   (if bit
     (values [20 207 253] [255 106 60])
@@ -6,25 +8,6 @@
 (fn pal-from-byte [byte]
   (pal-from-bit (not= 0 (bit.band byte 0x80))))
 
-(fn putpixel [x y color]
-  (when color
-    (love.graphics.setColor (/ (. color 1) 255) (/ (. color 2) 255) (/ (. color 3) 255))
-    (love.graphics.points (+ x 0.5) (+ y 0.5))))
-
-(fn make-canvas [w h f]
-  (local canvas (love.graphics.newCanvas w h))
-  (local prevcanvas (love.graphics.getCanvas))
-  (canvas:setFilter :nearest :nearest)
-  (local scissor [(love.graphics.getScissor)])
-  (love.graphics.setScissor)
-  (love.graphics.setCanvas canvas)
-  (love.graphics.clear 0 0 0)
-  (f canvas)
-  (love.graphics.setCanvas prevcanvas)
-  (love.graphics.setScissor (table.unpack scissor))
-  (love.graphics.setColor 1 1 1 1)
-  canvas)
-
 (fn draw-byte [bytes ibyte xoffset y ?state ?prevpal]
   (local byte (string.byte (bytes:sub ibyte ibyte)))
   (var prevstate nil)
@@ -105,32 +88,5 @@
       (for [y 0 7]
         (draw-byte gfx (+ y 1) 0 y))))))
 
-(fn TileCache [tiles ?spritegen]
-  {: tiles
-   :spritegen (or ?spritegen tile-to-sprite)
-   :tilesprites []
-   :tile (fn [self itile] (or (. self.tiles itile) {:flags {}}))
-   :cachekey (fn [itile ?key] (.. (or ?key :gfx) itile))
-   :update-tile
-   (fn [self itile tile ?key]
-     (tset self.tiles itile
-       (-> (self:tile itile)
-         (doto (tset (or ?key :gfx) tile))))
-     (tset self.tilesprites (self.cachekey itile ?key) nil))
-   :set-flag
-   (fn [self itile flag clear]
-     (tset (. self.tiles itile :flags) flag (if clear nil true)))
-   :load
-   (fn [self tiles]
-     (set self.tiles tiles)
-     (set self.tilesprites []))
-   :sprite
-   (fn [self itile ?key]
-     (local key (self.cachekey itile ?key))
-     (when (and (= nil (. self.tilesprites key)) (not= nil (. self.tiles itile)))
-       (tset self.tilesprites key (self.spritegen (. self.tiles itile (or ?key :gfx)))))
-     (. self.tilesprites key))})
-
-{: tile-to-sprite : tilestrip-to-sprite : portrait-to-sprite : char-to-sprite : scanline-to-sprite
- : screen-y-to-offset : pal-from-bit : pal-from-byte : TileCache : make-canvas : draw-byte}
-
+{: tile-to-sprite : char-to-sprite : portrait-to-sprite : screen-to-sprite : scanline-to-sprite : screen-y-to-offset
+ : tilestrip-to-sprite : pal-from-bit : pal-from-byte : draw-byte}

editor/tiledraw/iigs.fnl

@@ -0,0 +1,29 @@
+(local {: putpixel : make-canvas} (require :editor.tiledraw))
+(local tiles (require :game.tiles))
+
+; converted from http://pixeljoint.com/forum/forum_posts.asp?TID=12795 (db16)
+; maybe check out https://lospec.com/palette-list ?
+(local pal [[1 0 1]  [4 2 3]  [3 3 6]  [4 4 4]  [8 4 3]   [3 6 2]   [13 4 4]  [7 7 6]
+            [5 7 12] [13 7 2] [8 9 10] [6 10 2] [13 10 9] [6 12 12] [13 13 5] [13 14 13]])
+(fn gs-to-rgb [color] (icollect [_ v (ipairs (or color [0 0 0]))] (* v 0x11)))
+
+(fn spritegen-for-size [w h]
+  (fn [tile]
+    (when tile (make-canvas w h (fn [canvas]
+      (love.graphics.clear 0 0 0 0)
+      (for [y 0 (- h 1)]
+        (for [x 0 (- w 1)]
+          (let [ibyte (+ (* y w) x 1)
+                byte (string.byte (tile:sub ibyte ibyte))
+                mask (bit.band (bit.rshift byte 4) 0xf)
+                color (bit.band byte 0xf)
+                rgb (if (= mask 0) (gs-to-rgb (. pal (+ color 1))) [255 0 255])]
+            (when (= mask 0) (putpixel x y rgb))))))))))
+
+(local tile-to-sprite (spritegen-for-size 16 16))
+
+(fn spritegen-for-style [name]
+  (let [{: tilew : tileh} (tiles.style name)]
+    (spritegen-for-size tilew tileh)))
+
+{: tile-to-sprite : spritegen-for-size : spritegen-for-style : pal : gs-to-rgb}

editor/tiledraw/init.fnl

@@ -0,0 +1,69 @@
+(local files (require :game.files))
+(local TileDraw {})
+
+(fn TileDraw.putpixel [x y color]
+  (when color
+    (love.graphics.setColor (/ (. color 1) 255) (/ (. color 2) 255) (/ (. color 3) 255))
+    (love.graphics.points (+ x 0.5) (+ y 0.5))))
+
+(fn TileDraw.make-canvas [w h f]
+  (local canvas (love.graphics.newCanvas w h))
+  (local prevcanvas (love.graphics.getCanvas))
+  (canvas:setFilter :nearest :nearest)
+  (local scissor [(love.graphics.getScissor)])
+  (love.graphics.setScissor)
+  (love.graphics.setCanvas canvas)
+  (love.graphics.clear 0 0 0 0)
+  (f canvas)
+  (love.graphics.setCanvas prevcanvas)
+  (love.graphics.setScissor (table.unpack scissor))
+  (love.graphics.setColor 1 1 1 1)
+  canvas)
+
+(files.platform-methods TileDraw :editor.tiledraw
+  :tile-to-sprite :char-to-sprite :portrait-to-sprite :screen-to-sprite :screen-y-to-offset
+  :pal-from-bit :pal-from-byte :draw-byte)
+
+(files.default-platform-method TileDraw :editor.tiledraw :tilestrip-to-sprite
+  (fn [tiles style]
+    (let [spritegen (TileDraw.spritegen-for-style style)
+          sprites (icollect [_ tile (ipairs tiles)] (spritegen tile))]
+      (TileDraw.make-canvas (* (: (. sprites 1) :getWidth) (length sprites)) (: (. sprites 1) :getHeight)
+        #(each [isprite sprite (ipairs sprites)]
+          (love.graphics.draw sprite (* (sprite:getWidth) (- isprite 1)) 0))))))
+
+(files.default-platform-method TileDraw :editor.tiledraw :spritegen-for-style
+  (fn [style]
+    (match style
+       :font TileDraw.char-to-sprite
+       :brushes TileDraw.char-to-sprite
+       :portraits TileDraw.portrait-to-sprite
+       _ TileDraw.tile-to-sprite)))
+
+(fn TileDraw.TileCache [tiles ?spritegen]
+  {: tiles
+   :spritegen (or ?spritegen TileDraw.tile-to-sprite)
+   :tilesprites []
+   :tile (fn [self itile] (or (. self.tiles itile) {:flags {}}))
+   :cachekey (fn [itile ?key] (.. (or ?key :gfx) itile))
+   :update-tile
+   (fn [self itile tile ?key]
+     (tset self.tiles itile
+       (-> (self:tile itile)
+         (doto (tset (or ?key :gfx) tile))))
+     (tset self.tilesprites (self.cachekey itile ?key) nil))
+   :set-flag
+   (fn [self itile flag clear]
+     (tset (. self.tiles itile :flags) flag (if clear nil true)))
+   :load
+   (fn [self tiles]
+     (set self.tiles tiles)
+     (set self.tilesprites []))
+   :sprite
+   (fn [self itile ?key]
+     (local key (self.cachekey itile ?key))
+     (when (and (= nil (. self.tilesprites key)) (not= nil (. self.tiles itile)))
+       (tset self.tilesprites key (self.spritegen (. self.tiles itile (or ?key :gfx)))))
+     (. self.tilesprites key))})
+
+TileDraw

editor/tileedit.fnl

@@ -1,109 +0,0 @@
-(local GraphicsEditView (require :editor.gfxedit))
-(local style (require :core.style))
-(local tiles (require :game.tiles))
-(local files (require :game.files))
-(local tiledraw (require :editor.tiledraw))
-(local util (require :lib.util))
-(local {: mouse-inside : activate : active? : checkbox : textfield} (util.require :editor.imstate))
-
-(local TileView (GraphicsEditView:extend))
-
-(set TileView.pixel-size 24)
-(local pixel-size TileView.pixel-size)
-
-(fn TileView.map-bitxy [self x y]
-  (when (and (>= x 0) (< x 16) (>= y 0) (< y 16))
-    (local ibyte (if (< x 8) y (+ y 16)))
-    (local ibit
-      (if (= x 0) 7
-          (< x 8) (- x 1)
-                  (- x 8)))
-    (values ibyte ibit)))
-
-(fn TileView.tilesize [self] (values 16 16))
-(fn TileView.tilekeys [self]
-  (if files.game.tilesets (icollect [_ key (pairs files.game.tilesets)] key)
-    [:gfx]))
-
-(fn get-byte [tile ibyte]
-  (: (tile:sub (+ ibyte 1) (+ ibyte 1)) :byte))
-(fn get-bit [tile ibyte ibit]
-  (not= 0 (bit.band (get-byte tile ibyte) (bit.lshift 1 ibit))))
-(fn set-bit [tile ibyte ibit is-set]
-  (local orval (bit.lshift 1 ibit))
-  (-> (get-byte tile ibyte)
-    (bit.band (bit.bnot orval))
-    (bit.bor (if is-set orval 0))))
-
-(fn set-tile-bit [tile ibyte ibit is-set]
-  (util.splice tile ibyte (string.char (set-bit tile ibyte ibit is-set))))
-
-(fn draw-bit-color [bit x y]
-  (local (bgcolor color) (tiledraw.pal-from-bit bit))
-  (renderer.draw_rect x y pixel-size pixel-size bgcolor)
-  (renderer.draw_rect (+ x 3) (+ y 3) (- pixel-size 6) (- pixel-size 6) color))
-
-(fn draw-bit [bit x y even]
-  (renderer.draw_rect x y pixel-size pixel-size (if bit [255 255 255] [0 0 0])))
-
-(fn TileView.tile [self]
-  (local (w h) (self:tilesize))
-  (or (-?> self.tilecache.tiles (. self.itile) (. (or self.tilekey :gfx))) (string.rep "\0" (/ (* w h) 8))))
-
-(fn TileView.draw-tile-editor [self tile x y]
-  (when (not (active? self :tile))
-    (set self.bit nil))
-  (local (w h) (self:tilesize))
-  (local editor-w (* (+ pixel-size 1) w))
-  (local editor-h (* (+ pixel-size 1) h))
-  (activate self :tile x y editor-w editor-h)
-  (for [bitx 0 (- w 1)] (for [bity 0 (- h 1)]
-    (local (ibyte ibit) (self:map-bitxy bitx bity))
-    (local b (get-bit tile ibyte ibit))
-    (local (px py) (values (+ x (* bitx (+ pixel-size 1))) (+ y (* bity (+ pixel-size 1)))))
-    (if (= ibit 7)
-      (draw-bit-color b px py)
-      (draw-bit b px py (= (% bitx 2) 1)))
-    (when (and (active? self :tile) (mouse-inside px py pixel-size pixel-size))
-      (when (= self.bit nil) (set self.bit (not b)))
-      (when (not= self.bit b)
-        (self:update-tile (set-tile-bit tile ibyte ibit self.bit))))))
-  (love.graphics.setColor 1 1 1 1)
-  (values editor-w editor-h))
-
-(fn TileView.draw-tile-flag [self flagname x y]
-  (local flags (-?> self.tilecache.tiles (. self.itile) (. :flags)))
-  (local flagset (if flags (. flags flagname) false))
-  (let [(checked yNew) (checkbox self flagname flagset x y)]
-    (when checked (tset flags flagname (if flagset nil true)))
-    yNew))
-
-(fn TileView.draw-tile-flags [self x y]
-  (local tile (-?> self.tilecache.tiles (. self.itile)))
-  (var y y)
-  (when tile
-    (set (tile.word y) (textfield self "Default word" tile.word x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE)))
-    (set (tile.label y) (textfield self "Label" tile.label x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE))))
-  (each [iflag flagname (ipairs (tiles.flags))]
-    (set y (self:draw-tile-flag flagname x (+ y style.padding.y)))))
-
-(fn TileView.update-tile [self newtile]
-  (self.tilecache:update-tile self.itile newtile self.tilekey))
-
-(fn TileView.draw [self]
-  (self:draw_background style.background)
-  (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))
-  (self:draw-tile-flags (+ x editor-w pixel-size) y)
-  (var selector-y (+ y editor-h pixel-size))
-  (each [_ key (ipairs (self:tilekeys))]
-    (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 self.scrollheight (- selector-y y)))
-
-(fn TileView.resource-key [self] :tiles)
-(fn TileView.get_name [self] "Tile Editor")
-
-TileView

editor/tileedit/ii.fnl

@@ -0,0 +1,33 @@
+(local tiledraw (require :editor.tiledraw))
+
+(fn map-bitxy-tile [x y]
+  (when (and (>= x 0) (< x 16) (>= y 0) (< y 16))
+    (local ibyte (if (< x 8) y (+ y 16)))
+    (local ibit
+      (if (= x 0) 7
+          (< x 8) (- x 1)
+                  (- x 8)))
+    (values ibyte ibit 1)))
+
+(fn map-bitxy-portrait [x y]
+  (local quadrant (+ (if (>= x 16) 2 0) (if (>= y 16) 1 0)))
+  (local tilex
+    (if (or (= x 0) (= x 30))  0
+        (or (= x 1) (= x 31))  15
+        (< x 16)               (- x 1)
+                               (- x 15)))
+  (local tiley (% y 16))
+  (local (ibyte ibit) (map-bitxy-tile tilex tiley))
+  (values (+ ibyte (* quadrant 32)) ibit 1))
+
+{:map-bitxy (fn [self x y w] (if (> w 16) (map-bitxy-portrait x y) (map-bitxy-tile x y)))
+ :pixel-color (fn [self b _ ibit]
+   (if (= ibit 7) (tiledraw.pal-from-bit (= b 1))
+       (= b 1)    [255 255 255]
+                  [0 0 0]))
+ :draw-off  (fn [self]   (set self.bit nil))
+ :draw-on   (fn [self b] (when (= self.bit nil) (set self.bit (if (= b 1) 0 1))))
+ :draw-bits (fn [self] self.bit)
+ :pixel-storage-divisor #8
+}
+

editor/tileedit/iigs.fnl

@@ -0,0 +1,16 @@
+(local {: pal : gs-to-rgb} (require :editor.tiledraw.iigs))
+(local lume (require :lib.lume))
+
+{:map-bitxy (fn [self x y w h] (values (+ (* y w) x) 0 0xff))
+ :pixel-color (fn [self b] (match b 0xf0 (values [128 128 128] [64 64 64])
+                                  _ (gs-to-rgb (. pal (+ b 1)))))
+ :draw-bits #(if (= $1.icolor 17) 0xf0 (- $1.icolor 1))
+ :palette #(lume.concat (icollect [_ color (ipairs pal)] (gs-to-rgb color)) [[255 0 255]])
+ :pixel-storage-divisor #1
+ :blank-tile-byte #"\xf0"
+ :preview-locations (fn [self]
+   (match self.style
+     :iso [[12 0] [0 6] [24 6] [12 12]]
+     _ [[0 0] [12 0] [0 12] [12 12]]))
+}
+

editor/tileedit/init.fnl

@@ -0,0 +1,157 @@
+(local GraphicsEditView (require :editor.gfxedit))
+(local style (require :core.style))
+(local tiles (require :game.tiles))
+(local files (require :game.files))
+(local util (require :lib.util))
+(local lume (require :lib.lume))
+(local {: show} (util.require :inspector.debug))
+(local {: mouse-inside : activate : active? : checkbox : textfield : button : dropdown : with-style
+        : under : right-of : reform : horiz-wrapper : group-wrapper} (util.require :editor.imgui))
+
+(local TileView (GraphicsEditView:extend))
+
+(set TileView.pixel-size 24)
+(local pixel-size TileView.pixel-size)
+
+(fn TileView.tilekeys [self]
+  (if files.game.tilesets (icollect [_ key (pairs files.game.tilesets)] key)
+    [:gfx]))
+(fn TileView.tilebytelen [self] (let [(w h) (self:tilesize)] (/ (* w h) (self:pixel-storage-divisor))))
+
+(fn get-byte [tile ibyte]
+  (or (: (tile:sub (+ ibyte 1) (+ ibyte 1)) :byte) 0))
+(fn get-bits [tile ibyte ibit mask]
+  (-> (get-byte tile ibyte)
+      (bit.band (bit.lshift mask ibit))
+      (bit.rshift ibit)))
+(fn set-bits [tile ibyte ibit mask bits]
+  (local orval (bit.lshift mask ibit))
+  (-> (get-byte tile ibyte)
+    (bit.band (bit.bnot orval))
+    (bit.bor (bit.lshift bits ibit))))
+
+(fn set-tile-bits [tile ibyte ibit mask bits]
+  (util.splice tile ibyte (string.char (set-bits tile ibyte ibit mask bits))))
+
+(files.platform-methods TileView :editor.tileedit :map-bitxy :pixel-color :draw-on :draw-off :draw-bits
+  :palette :pixel-storage-divisor)
+
+(files.default-platform-method TileView :editor.tileedit :preview-locations
+  (fn [self] (let [(w h) (self:tilesize)] [[0 0] [w 0] [0 h] [w h]])))
+
+(files.default-platform-method TileView :editor.tileedit :blank-tile-byte #"\0")
+
+(fn TileView.tile [self]
+  (local (w h) (self:tilesize))
+  (or (-?> self.tilecache.tiles (. self.itile) (. (or self.tilekey :gfx)))
+      (string.rep (self:blank-tile-byte) (/ (* w h) (self:pixel-storage-divisor)))))
+
+(fn TileView.draw-pixel [self x y colorbg ?colorfg]
+  (renderer.draw_rect x y pixel-size pixel-size colorbg)
+  (when ?colorfg (renderer.draw_rect (+ x 3) (+ y 3) (- pixel-size 6) (- pixel-size 6) ?colorfg)))
+
+(fn tile-editor [{:view self : x : y &as form} tile]
+  (local {: tag} (with-style form :tag :tile))
+  (when (not (active? self tag)) (self:draw-off))
+  (local (w h) (self:tilesize))
+  (set form.w (* (+ pixel-size 1) w))
+  (set form.h (* (+ pixel-size 1) h))
+  (activate form)
+  (for [bitx 0 (- w 1)] (for [bity 0 (- h 1)]
+    (local (ibyte ibit mask) (self:map-bitxy bitx bity w h))
+    (local b (get-bits tile ibyte ibit mask))
+    (local (px py) (values (+ x (* bitx (+ pixel-size 1))) (+ y (* bity (+ pixel-size 1)))))
+    (local (colorbg colorfg) (self:pixel-color b ibyte ibit))
+    (self:draw-pixel px py colorbg colorfg)
+    (when (and (active? self tag) (mouse-inside px py pixel-size pixel-size))
+      (self:draw-on b)
+      (local bits (self:draw-bits))
+      (when (not= bits b)
+        (self:update-tile (set-tile-bits tile ibyte ibit mask bits))))))
+  (love.graphics.setColor 1 1 1 1))
+
+(fn TileView.draw-tile-editor [self form tile] (tile-editor form tile))
+
+(fn tile-flag [form tile flagname]
+  (local flagset (?. tile :flags flagname))
+  (when (checkbox form flagname flagset)
+    (tset tile :flags flagname (if flagset nil true))))
+
+(fn TileView.draw-tile-flags [self form]
+  (let [tile (-?> self.tilecache.tiles (. self.itile))
+        fieldform {:wlabel (* 100 SCALE) :wtext (* 200 SCALE)}]
+    (when tile
+      (set tile.word (textfield (reform form fieldform) "Default word" tile.word))
+      (set tile.label (textfield (under form fieldform) "Label" tile.label)))
+    (each [iflag flagname (ipairs (tiles.flags))]
+      (tile-flag (under form) tile flagname))))
+
+(fn tile-preview [{:view self : x : y &as form} itile tilekey]
+  (each [_ [tx ty] (ipairs (self:preview-locations))]
+    (let [dx (* tx self.sprite-scale) dy (* ty self.sprite-scale)
+          (w h) (self:draw-sprite (+ x dx) (+ y dy) itile tilekey)]
+      (when (and w (or (= form.w nil) (< form.w (+ w dx)))) (set form.w (+ w dx)))
+      (when (and h (or (= form.h nil) (< form.h (+ h dy)))) (set form.h (+ h dy))))))
+(fn TileView.draw-tile-preview [self form] (tile-preview form self.itile self.tilekey))
+
+(fn tile-palette [{:view self : x : y : w &as form} pal selected-color]
+  (let [g (group-wrapper (with-style form))
+        wrap (horiz-wrapper form)]
+    (var selected-color selected-color)
+    (each [icolor color (ipairs pal)]
+      (renderer.draw_rect form.x form.y pixel-size pixel-size color)
+      (when (= icolor selected-color)
+        (love.graphics.setColor 1 1 1 1)
+        (love.graphics.rectangle :line (- form.x 2) (- form.y 2) (+ pixel-size 4) (+ pixel-size 4)))
+      (when (g button (reform form {:tag [:pal icolor] :w pixel-size :h pixel-size}))
+        (set selected-color icolor))
+      (wrap form))
+    (g)
+    selected-color))
+
+(fn TileView.draw-tile-palette [self form]
+  (match (self:palette)
+    pal (set self.icolor (tile-palette form pal self.icolor))))
+
+(fn TileView.update-tile [self newtile]
+    (self.tilecache:update-tile self.itile newtile self.tilekey))
+
+(fn style-selector [form current-style]
+  (let [{:view self : x : y : font : color : ypad} (with-style form)
+        form-drop (lume.merge form {:x (+ x (* 50 SCALE)) :w (* 100 SCALE) :tag :layer-selector})
+        selection (dropdown form-drop current-style (tiles.tile-styles))]
+    (renderer.draw_text font "Style" x (+ y (/ ypad 2)) color)
+    (set form.w (- (+ form-drop.x form-drop.w) x))
+    (set form.h form-drop.h)
+    (when (not= current-style selection) selection)))
+
+(fn TileView.draw-style-selector [self form]
+  (match (style-selector form self.style)
+    new-style (self:set-style new-style)))
+
+(fn TileView.draw-sidebar [self form]
+  (self:draw-tile-flags form)
+  (self:draw-tile-preview (under form)))
+
+(fn TileView.draw [self]
+  (self:draw_background style.background)
+  (self:draw_scrollbar)
+  (let [form (self:form)
+        full-width {:w form.w}]
+    (self:draw-tile-editor form (self:tile))
+
+    ; layout sidebar
+    (self:draw-sidebar (right-of form {:into {}}))
+
+    ; continue laying out under tile editor
+    (self:draw-tile-palette (under form full-width))
+    (when (> (length (tiles.tile-styles)) 1)
+      (self:draw-style-selector (under form)))
+    (each [_ key (ipairs (self:tilekeys))]
+      (self:draw-tile-selector (under form full-width) key))
+    (self:end-scroll form)))
+
+(fn TileView.initial-style [self] :tiles)
+(fn TileView.get_name [self] "Tile Editor")
+
+TileView

game/files.fnl

@@ -1,10 +1,9 @@
 (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 default-filename "neutgs/game.json")
 
 (local encoded-tile-fields [:gfx :mask])
 (fn convert [tile field method]
@@ -30,15 +29,30 @@
 (fn deserialize [key value root]
   (match key
     (where (or :tiles :portraits :font :brushes)) (tile-deserialize value root)
-    :levels (do (set value.map (value.map:fromhex)) value)
+    :levels (do (set value.map (value.map:fromhex))
+                (set value.layers (icollect [_ layer (ipairs (or value.layers []))] (layer:fromhex)))
+                value)
     _ value))
 
 (fn serialize [key value root]
   (match key
     (where (or :tiles :portraits :font :brushes)) (tile-serialize value root)
-    :levels (do (set value.map (value.map:tohex)) value)
+    :levels (do (set value.map (value.map:tohex))
+                (set value.layers (icollect [_ layer (ipairs (or value.layers []))] (layer:tohex)))
+                value)
     _ value))
 
+; serialization, take 2: just always convert unprintable strings to hex everywhere
+(fn deserialize2 [o]
+  (if (and (= (type o) :table) o.__hex__) (o.__hex__:fromhex)
+      (= (type o) :table) (collect [k v (pairs o)] (values k (deserialize2 v)))
+    o))
+(fn printable? [s] (= (string.match s "[^%w%s%p]") nil))
+(fn serialize2 [o]
+  (if (and (= (type o) :string) (not (printable? o))) {:__hex__ (o:tohex)}
+      (= (type o) :table) (collect [k v (pairs o)] (values k (serialize2 v)))
+    o))
+
 (fn clone [v]
   (match (type v)
     :table (lume.clone v)
@@ -49,30 +63,31 @@
   (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)
+           (let [game (util.readjson (filename))]
+             (if (= game.version 2) (deserialize2 game)
+               (do (each [k v (pairs game)]
+                     (when (= (type v) :table)
+                       (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))))
+  (let [game (serialize2 files.game)]
+    (set game.version 2)
     (util.writejson (filename) game)))
 
 (fn new-cache [game key]
-  (let [spritegen (match key
-                         :font tiledraw.char-to-sprite
-                         :brushes tiledraw.char-to-sprite
-                         :portraits tiledraw.portrait-to-sprite
-                         _ tiledraw.tile-to-sprite)
+  (let [tiledraw (require :editor.tiledraw)
+        tiles (require :game.tiles)
+        spritegen (tiledraw.spritegen-for-style key)
         gfx (. game key)]
     (tiledraw.TileCache gfx spritegen)))
 
 (fn files.cache [key]
+  (when (= (. files.game key) nil)
+    (tset files.game key []))
   (when (= (?. files :tilecaches key) nil)
     (util.nested-tset files [:tilecaches key] (new-cache files.game key)))
   (. files.tilecaches key))
@@ -86,6 +101,12 @@
 (fn files.module []
   (or files.game.module (: (filename) :match "^[^/]+")))
 
+(fn files.platform [] (or files.game.platform :ii))
+(fn files.default-platform-method [cls module-prefix method default]
+  (tset cls method (fn [...] (let [f (. (require (.. module-prefix :. (files.platform))) method)] (if f (f ...) (default ...))))))
+(fn files.platform-methods [cls module-prefix ...]
+  (each [_ key (ipairs [...])] (files.default-platform-method cls module-prefix key #nil)))
+
 (when (= files.game nil)
   (files.load))
 

game/tiles.fnl

@@ -2,6 +2,29 @@
 (local lume (require :lib.lume))
 (local files (require :game.files))
 
+(local platforms {
+  :ii   {:mapw 20 :maph 12 :tilew 14 :tileh 16 :editw 16
+         :font {:tilew 7 :editw 8 :tileh 8}
+         :brushes {:tilew 7 :editw 8 :tileh 8}
+         :portraits {:tilew 28 :editw 32 :tileh 32}}
+  :iigs {:mapw 26 :maph 16 :tilew 12 :tileh 12
+         :layers [{:style :tiles} {:style :iso :x 6 :y 6} {:style :iso :x 6}]
+         :yoffsets [0 6 0]
+         :iso {:mapw 12 :maph 28 :tilew 24 :tileh 32 :xstagger 12 :ystagger 6}
+         :font {:tilew 8 :tileh 8}
+         :brushes {:tilew 8 :tileh 8}
+         :portraits {:tilew 32 :tileh 32}}
+})
+
+(fn dimensions [] (. platforms (files.platform)))
+(fn style [name] (or (. (dimensions) name) (dimensions)))
+(fn tile-styles [include-details]
+  (let [dim (dimensions)
+        styles {:tiles dim}]
+    (each [_ {:style layer} (ipairs (or dim.layers []))]
+      (when (not= layer :tiles) (tset styles layer (. dim layer))))
+    (if include-details styles (lume.keys styles))))
+
 (fn flags [] (or files.game.tileflags [:walkable]))
 (fn flag-to-bit []
   (collect [iflag flag (ipairs (flags))] (values flag (bit.lshift 1 (- iflag 1)))))
@@ -55,5 +78,5 @@
     (find-itile tiles label (+ itile 1))))
 
 {: appendtiles : appendgfx : append-portraitwords : flags : flag-to-bit : find-itile
- : encode-yx : encode-itile : decode-itile}
+ : encode-yx : encode-itile : decode-itile : dimensions : tile-styles : style}
 

inspector/debug.fnl

@@ -0,0 +1,30 @@
+(local core (require :core))
+(local style (require :core.style))
+(local util (require :lib.util))
+(local repl (require :editor.repl))
+(local ReplView (require :editor.replview))
+
+(local module (util.hot-table ...))
+
+(fn find-existing-inspector-window [name]
+  (var result nil)
+  (each [_ view (ipairs (core.root_view.root_node:get_children)) :until result]
+    (when (= view.inspector-name name)
+      (set result view)))
+  result)
+
+(fn create-inspector-window [name ?value]
+  (let [node (core.root_view:get_active_node)
+        conn (repl.new)
+        view (ReplView conn)]
+    (set view.inspector-name name)
+    (set view.title name)
+    (view:append {:draw (fn [_ _ x y] (renderer.draw_text style.font name x y style.text) (+ (style.font:get_height) style.padding.y))})
+    (view:append (repl.mk-result [?value]))
+    (node:add_view view)))
+
+(lambda module.show [name ?value]
+  (when (= (find-existing-inspector-window name) nil)
+    (create-inspector-window name ?value)))
+
+module.hot

inspector/init.fnl

@@ -1,7 +1,7 @@
 (local util (require :lib.util))
 (local style (require :core.style))
 (local {: defmulti : defmethod} (util.require :lib.multimethod))
-(local {: textbutton} (util.require :editor.imstate))
+(local {: textbutton : label : under : right-of : reform : group-wrapper  } (util.require :editor.imgui))
 
 (local inspector (util.hot-table ...))
 
@@ -15,7 +15,7 @@
   best-inspector)
 
 (set inspector.inspect
-  (defmulti (fn [state value view x y w]
+  (defmulti (fn [form state value]
               (when (= state.inspector nil)
                 (set state.inspector (inspector.best-inspector value)))
               state.inspector) :inspect ...))
@@ -26,43 +26,29 @@
   (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 :default 0 #true (fn [form state value]
+  (label (reform form {:font style.code_font}) (fv value))))
 
 (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))
+  (fn [form state tbl]
+    (let [get-kstate (fn [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))
+          g (group-wrapper form)]
+      (each [k v (pairs tbl)]
+        (let [kstate (get-kstate tbl k state)]
+          ; todo: state assumes an .inspector key
+          ; todo: inspector swapping
+          ; todo: edit in place?
+          (when (g textbutton (under form {:font style.code_font}) (fv k))
+            (set kstate.collapsed (not kstate.collapsed)))
+          (if kstate.collapsed
+             (g label (right-of form {:color style.syntax.comment :into {}}) "...")
+             (g #(inspector.inspect $...) (right-of form {:into {}}) kstate.children v))
+          (g))))))
 
 inspector.hot
 

lib/util.fnl

@@ -9,20 +9,28 @@
 
 (fn lo [v] (bit.band v 0xff))
 (fn hi [v] (bit.band (bit.rshift v 8) 0xff))
+(fn loword [v] (bit.band v 0xffff))
+(fn hiword [v] (bit.band (bit.rshift v 16) 0xffff))
+
 (fn int8-to-bytes [i]
   (string.char (lo i)))
 (fn int16-to-bytes [i]
   (string.char (lo i) (hi i)))
 (fn int24-to-bytes [i]
-  (string.char (lo i) (hi i) (bit.band (bit.rshift i 16) 0xff)))
+  (string.char (lo i) (hi i) (lo (bit.rshift i 16))))
+(fn int32-to-bytes [i]
+  (string.char (lo i) (hi i) (lo (bit.rshift i 16)) (hi (bit.rshift i 16))))
 (fn bytes-to-uint8 [b ?offset]
   (string.byte b (+ 1 (or ?offset 0)) (+ 1 (or ?offset 0))))
 (fn bytes-to-uint16 [b ?offset]
-  (local (lo hi) (string.byte b (+ 1 (or ?offset 0))   (+ 2 (or ?offset 0))))
+  (local (lo hi) (string.byte b (+ 1 (or ?offset 0)) (+ 2 (or ?offset 0))))
   (bit.bor lo (bit.lshift hi 8)))
 (fn bytes-to-uint24 [b ?offset]
   (local (lo mid hi) (string.byte b (+ 1 (or ?offset 0)) (+ 3 (or ?offset 0))))
   (bit.bor lo (bit.lshift mid 8) (bit.lshift hi 16)))
+(fn bytes-to-uint32 [b ?offset]
+  (local [lo hi] [(bytes-to-uint16 b ?offset) (bytes-to-uint16 b (+ 2 (or ?offset 0)))])
+  (bit.bor lo (bit.lshift hi 16)))
 
 (fn splice [bytes offset str]
   (.. (bytes:sub 1 offset)
@@ -111,8 +119,24 @@
     (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
- : splice : lo : hi
- : reload : hotswap : swappable :require swappable-require : hot-table : nested-tset
+(fn pairoff [l]
+  (fn [_ iprev] (let [i (if iprev (+ iprev 2) 1)]
+                          (when (< i (length l)) (values i (. l i) (. l (+ i 1)))))))
+
+(fn countiter [minmax ?max ?step]
+  (let [min (if ?max minmax 1)
+        max (or ?max minmax)
+        step (or ?step 1)]
+    (fn [_ iprev]
+      (let [i (if iprev (+ iprev step) min)]
+        (when (if (> step 0) (<= i max) (>= i max)) i)))))
+
+(fn condlist [...] (let [l []] (lume.push l ...) l))
+
+(fn prototype [base] (setmetatable {} {:__index base}))
+
+{: int8-to-bytes : int16-to-bytes : int24-to-bytes : int32-to-bytes : bytes-to-uint8 : bytes-to-uint16 : bytes-to-uint24 : bytes-to-uint32
+ : splice : lo : hi : loword : hiword : condlist : prototype
+ : reload : hotswap : swappable :require swappable-require : hot-table : nested-tset : pairoff : countiter
  : readjson : writejson : file-exists : waitfor : in-coro : multival}
 

link/init.fnl

@@ -3,7 +3,7 @@
    (fn [self name]
      (set self.machine (require (.. "link." name)))
      (set self.name name))
-   :types [:serial :tape :mame]})
+   :types [:serial :tape :mame :udpdebug]})
 
 (local serial (require :link.serial))
 (link:switch (if (and (pcall #(serial:connect)) (serial:connected?)) :serial :mame))

link/mame.fnl

@@ -23,7 +23,7 @@
   (set self.breakpoints {}))
 (fn Machine.boot [self]
   (when (not self.pid)
-    (set self.pid (start-mame :apple2e))))
+    (set self.pid (start-mame :apple2gs))))
 (fn Machine.run [self]
   (self:boot)
   (self:connect))
@@ -70,7 +70,7 @@
          (var last-addr ?last-addr)
          (while (let [state manager.machine.debugger.execution_state
                       addr (. manager.machine.devices ::maincpu :state :PC :value)]
-                    (not (and (= state :stop) (not= addr ?last-addr))))
+                    (not (and (= state :stop) (not= addr last-addr))))
            (when (= :run manager.machine.debugger.execution_state)
              (set last-addr nil))
            (coroutine.yield))))
@@ -141,7 +141,7 @@
     (bencode.encode addr-to-bytes)))
 (fn Machine.launch [self prg]
   (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 \"\n\nCALL-151\\n %xG\\n\")" (prg:lookup-addr prg.start-symbol))))
 (fn Machine.reboot [self] (self:eval "(manager.machine:hard_reset)"))
 (fn Machine.coro-eval [self code ?handlers]
   (var result nil)
@@ -174,7 +174,7 @@
   (self:set-bp addr
     #(util.in-coro (fn []
        (self:clear-bp addr)
-       (local hotswap (prg-old:read-hotswap self))
+       (local hotswap (prg-old:read-hotswap self prg-new))
        (prg-new:upload self)
        (prg-new:write-hotswap self hotswap)
        (self:jump (prg-new:lookup-addr :on-hotswap))

link/nrepl.fnl

@@ -72,7 +72,6 @@
      (tset self.active-requests msg-id nil))
    :handle
    (fn [self response]
-     (pp response)
      (local handlers (self:merge-handlers response))
      (each [prop handler (pairs handlers)]
        (local idiv (prop:find :/))

link/udpdebug.fnl

@@ -0,0 +1,153 @@
+(local core (require :core))
+(local socket (require :socket))
+(local {: int16-to-bytes : int32-to-bytes : bytes-to-uint16 : bytes-to-uint32 : lo : in-coro} (require :lib.util))
+(local Ssc (require :ssc))
+(import-macros {:sss ! : compile} :ssc.macros)
+
+(local config {
+  :host "172.24.1.6"
+  :port 6502
+})
+
+{:cmd {
+   :write 0
+   :read 1
+   :eval 2
+   :pause 3
+   :ping 4
+ }
+ :response {
+   :ack 0
+   :data 1
+ }
+ :pending {}
+ :msgid 0
+ :waiting false
+ :queue []
+ :connect
+ (fn [self ?port ?host]
+   (when (not self.connection)
+     (local [port host] [(or ?port config.port) (or ?host config.host)])
+     (set self.connection (assert (socket.udp)))
+     (assert (self.connection:setpeername host port))
+     (self.connection:settimeout 0)
+     (core.add_thread #(while (self:connected?) (self:receive) (coroutine.yield)) self.connection)))
+ :connected? (fn [self] (not= self.connection nil))
+ :disconnect
+ (fn [self]
+   (when self.connection
+     (self.connection:close)
+     (set self.connection nil)
+     (set self.pending {})
+     (set self.queue [])
+     (set self.waiting false)))
+ :next-msgid
+ (fn [self]
+   (set self.msgid (lo (+ self.msgid 1)))
+   self.msgid)
+ :send
+ (fn [self cmd ?data ?callback]
+   (self:enqueue
+     #(let [msgid (self:next-msgid)
+            msg (.. (string.char msgid cmd) (or ?data ""))]
+        (print "sending" msgid cmd (length msg))
+        (when ?callback
+          (tset self.pending msgid ?callback)
+          (set self.waiting true))
+        (self.connection:send msg))))
+ :receive
+ (fn [self]
+   (when self.connection
+     (let [data (self.connection:receive)]
+       (when data
+         (let [msgid (string.byte (data:sub 1 1))
+               cmd   (string.byte (data:sub 2 2))
+               pendingfn (. self.pending msgid)]
+           (print "recieved" msgid cmd)
+           (when pendingfn
+             (tset self.pending msgid nil)
+             (pendingfn self cmd (data:sub 3)))
+           (set self.waiting false)))
+       (when (and (not self.waiting) (> (length self.queue) 0))
+         (let [f (. self.queue 1)]
+           (table.remove self.queue 1)
+           (f))))))
+ :enqueue (fn [self f] (table.insert self.queue f))
+ :eval (fn [self c {: parent : org : ignore-result}]
+   (let [parent (or parent (require :ssc.iigs.u2-debug))
+         ssc (Ssc {: parent})
+         org (or org (parent.prg:lookup-addr :u2-debug-buffer))]
+     (compile ssc
+       (org [org])
+       (fn do-the-thing () [c]))
+     (ssc:assemble)
+     (if (not ignore-result)
+         (let [(_ data) (self:coro-send self.cmd.eval (. ssc.prg.org-to-block org :bytes))]
+           {:word (bytes-to-uint16 data) :long (bytes-to-uint32 data 2)})
+       (self:send self.cmd.eval (. ssc.prg.org-to-block org :bytes)))))
+ :jump (fn [self addr] (self:eval (! (asm (jsl [(tostring addr)]))) {:ignore-result true}))
+ :coro-send
+ (fn [self cmd ?data]
+   (let [coro (coroutine.running)]
+     (self:send cmd ?data #(coroutine.resume coro $2 $3))
+     (coroutine.yield)))
+ :handle-ack (fn [self cmd] (assert (= cmd self.response.ack)))
+ :split-batches (fn [self blocks max-size]
+   ; just make sure it's legal, not optimal - no need to solve an NP-hard bin-packing problem
+   (fn add-to-batch [batches iblock size]
+     (let [batch (. batches (length batches))
+           block (. blocks iblock)]
+       (if (= block nil) batches
+           ; must be split into multiple batches
+           (> block.len max-size)
+           (do (for [i 0 (- block.len 1) max-size]
+                 (when (and (= i 0) (= (length batch) 0)) (table.remove batches))
+                 (table.insert batches [{:addr (+ block.addr i)
+                                         :data (when block.data (block.data:sub (+ i 1) (+ i max-size)))
+                                         :len (math.min (- block.len i) max-size)
+                                         :offset 1
+                                         :append-to-addr block.addr}]))
+               (add-to-batch batches (+ iblock 1) (if (= (% block.len max-size) 0) max-size (% block.len max-size))))
+           ; we have run off the end of the current batch
+           (> (+ size block.len) max-size)
+           (do (table.insert batches [])
+               (add-to-batch batches iblock 0))
+         ; there is enough space to fit into the current batch
+         (do (set block.offset (+ size 1))
+             (table.insert batch block)
+             (add-to-batch batches (+ iblock 1) (+ size block.len))))))
+   (add-to-batch [[]] 1 0))
+ :read-batch (fn [self addr-to-len]
+   (let [blocks (icollect [addr len (pairs addr-to-len)] {: addr : len})
+         result {}]
+     (each [_ batch (ipairs (self:split-batches blocks 1450))]
+       (let [msg (.. (int16-to-bytes (length batch))
+                     (table.concat (icollect [_ {: addr : len} (ipairs batch)] (.. (int32-to-bytes addr) (int16-to-bytes len)))))
+             (response data) (self:coro-send self.cmd.read msg)]
+         (assert (= response self.response.data))
+         (each [_ {: addr : len : offset : append-to-addr} (ipairs batch)]
+           (let [read-data (data:sub offset (+ offset len -1))]
+             (if append-to-addr (tset result append-to-addr (.. (. result append-to-addr) read-data))
+               (tset result addr read-data))))))
+     result))
+ :read (fn [self addr len] (. (self:read-batch {addr len}) addr))
+ :write-batch (fn [self addr-to-data]
+   (let [blocks (icollect [addr data (pairs addr-to-data)] {: addr :len (+ (length data) 6) : data})]
+     (each [_ batch (ipairs (self:split-batches blocks 1450))]
+       (let [msg (.. (int16-to-bytes (length batch))
+                     (table.concat (icollect [_ {: addr : data} (ipairs batch)] (.. (int32-to-bytes addr) (int16-to-bytes (length data)) data))))]
+         (print "writing batch of size" (length batch) (length msg))
+         (self:send self.cmd.write msg self.handle-ack)))))
+ :write (fn [self addr data] (self:write-batch {addr data}))
+ :pause  (fn [self] (self:send self.cmd.pause (int16-to-bytes 0xffff) self.handle-ack))
+ :resume (fn [self] (self:send self.cmd.pause (int16-to-bytes 0) self.handle-ack))
+ :launch (fn [self prg] (self:jump (prg:lookup-addr prg.start-symbol)))
+ :hotswap
+ (fn [self prg-old prg-new]
+   (in-coro (fn []
+     (self:pause)
+     (local hotswap (prg-old:read-hotswap self prg-new))
+     (prg-new:upload self)
+     (prg-new:write-hotswap self hotswap)
+     (self:resume))))
+}

main.lua

@@ -1,6 +1,7 @@
 -- bootstrap the compiler
 fennel = require("lib.fennel")
-table.insert(package.loaders, fennel.make_searcher())
+table.insert(package.loaders, fennel.searcher)
+debug.traceback = fennel.traceback
 fv = fennel.view
 pp = function(x) print(fv(x)) end
 lume = require("lib.lume")

neutgs/init.fnl

@@ -0,0 +1,129 @@
+(local Ssc (require :ssc))
+(local files (require :game.files))
+(local {: pal} (require :editor.tiledraw.iigs))
+(local u2-debug (require :ssc.iigs.u2-debug))
+(local link (require :link))
+(import-macros {:sss ! : compile} :ssc.macros)
+
+(local ssc (Ssc {:parent u2-debug}))
+(compile ssc
+  (require ssc.iigs.bootstub)
+  (require ssc.iigs.toolbox)
+  (require ssc.iigs.graphics)
+
+  (tooltable toolsets
+    ToolsetIntegerMath  0x0100
+    ToolsetText         0x0100
+    ToolsetQuickDraw    0x0100
+    ToolsetEventManager 0x0100
+    5                   0x0100  ; desk manager
+    9                   0x0100) ; ADB
+
+  (buffer hexbuf (cstr "    "))
+
+  (fn printnum (num)
+    (long! (ref hexbuf) (HexIt num))
+    (WriteCString (far-ref hexbuf)))
+
+  (asm event-buffer)
+  (global word event-what)
+  (global long event-msg)
+  (global long event-when)
+  (global word event-y)
+  (global word event-x)
+  (global word event-mod)
+
+  (fn wait-for-key ()
+    (FlushEvents keyDownMask 0)
+    (while (not (GetNextEvent keyDownMask (far-ref event-buffer)))
+      (yield)))
+
+  (define screen-addr 0xe12000)
+  (define screen-size 0x9d00)
+
+  (compile-sprite tile0 [(. files.game.iso 3 :gfx)] 24 32)
+  (compile-sprite tile1 [(. files.game.iso 5 :gfx)] 24 32)
+  (compile-sprite tile2 [(. files.game.iso 11 :gfx)] 24 32)
+  (compile-sprite tile3 [(. files.game.iso 12 :gfx)] 24 32)
+  (asm tiles (jmp tile0) (nop) (jmp tile1) (nop) (jmp tile2) (nop) (jmp tile3) (nop))
+
+  (form set-palette [(fn [ssc index pal]
+    (let [addr (+ 0xe19e00 (* index 0x20))
+          writes (icollect [icolor [r g b] (ipairs pal)]
+                   [[:lda (bit.bor (bit.lshift r 8) (bit.lshift g 4) b)] [:sta (tostring (+ addr (* icolor 2) -2))]])]
+      (lume.concat [:block] (table.unpack writes))))])
+
+  (global word userID)
+
+  (fn print-numbers-forever ()
+    (let (i 0) (while true
+      (printnum i)
+      (yield)
+      (set! i (+ i 1)))))
+
+  (form itile-to-tile [(fn [ssc itile]
+    [:block (ssc:expr-word itile) [:asl] [:asl] [:clc] [:adc #($1:lookup-addr :tiles)]])])
+
+  (global word with-shadowing 0)
+
+  (fn draw-test-tiles (i)
+    (when with-shadowing (disable-shadow-writes))
+    (let (x 0 y 0 screen 0x2000)
+      (while (< y 26)
+        (let (tile (itile-to-tile (& (+ x y i) 3)))
+          (draw-object screen tile))
+        (set! x (+ x 1))
+        (if (= x 12)
+          (do (set! y (+ y 1))
+              (set! x 0)
+              (set! screen (+ screen (if (& y 1) [(+ (- 160 (* 11 12)) (* 160 5) 6)]
+                                                 [(+ (- 160 6 (* 11 12)) (* 160 5))]))))
+          (set! screen (+ screen 12))))))
+
+  (fn draw-test-tiles-forever ()
+    (let (i 0)
+      (forever
+        (draw-test-tiles i)
+        (yield)
+        (set! i (+ i 1)))))
+
+  (fn debug-task () (forever [(if (= link.name :udpdebug) [:u2-debug-server-poll] [:do])] (yield)))
+  (far-fn main ()
+    (new-task (ref debug-task))
+
+    (LoadTools (far-ref toolsets))
+    (set! userID (MMStartUp))
+    (IMStartUp)
+    (TextStartUp)
+    (QDStartUp 0x3100 0 0 userID)
+    (EMStartUp 0x3000 0 0 320 0 200 userID)
+    (GrafOn)
+    (ClearScreen 0)
+    (let (screen 0x12000) (while (< screen 0x1a000)
+      (word! screen 0)
+      (set! screen (+ screen 2))))
+    (set-palette 0 [pal])
+    (SetAllSCBs 0)
+
+    (enable-shadow-writes)
+    (draw-test-tiles 0)
+    (wait-for-key)
+    (let (tile-task (new-task (ref draw-test-tiles-forever)))
+      (wait-for-key)
+;       (set! with-shadowing 1)
+;       (wait-for-key)
+;       (set! with-shadowing 2)
+;       (wait-for-key)
+;       (set! with-shadowing false)
+      (reset-task tile-task (ref yield-forever))
+      (wait-for-key))
+
+    (GrafOff)
+
+    (EMShutDown)
+    (QDShutDown)
+    (TextShutDown)
+    (IMShutDown)
+    (MMShutDown userID)))
+
+(ssc:assemble)

presentation/engine.fnl

@@ -2,7 +2,7 @@
 (local style (require :core.style))
 (local common (require :core.common))
 (local View (require :core.view))
-(local {: attach-imstate : textbutton} (require :editor.imstate))
+(local {: attach-imstate : textbutton} (require :editor.imgui))
 
 (local SlideshowView (View:extend))
 (fn SlideshowView.parse [slides]
@@ -107,13 +107,10 @@
 
 (fn SlideshowView.render-element [self element y]
   (if element.button
-      (let [(pressed yNext) (textbutton self
-                                        element.text
-                                        (+ self.position.x (self:justify element (element.font:get_width element.text)))
-                                        y
-                                        element.font)]
-        (when pressed (element:button))
-        (self:next-y element (- yNext y) y))
+      (let [form {:view self :font element.font
+                  :x (+ self.position.x (self:justify element (element.font:get_width element.text))) : y}]
+        (when (textbutton form element.text) (element:button))
+        (self:next-y element form.h y))
 
       element.text
       (let [lines (self:word-wrap element)

presentation/slides.fnl

@@ -25,8 +25,9 @@
    :justify :left
    :lowerPadding 7
    :pause-after true})
-(fn p [style ?text] (lume.merge style {:pause-after true} (if ?text {:text ?text :style false})))
-(fn np [style ?text] (lume.merge style {:pause-after false} (if ?text {:text ?text :style false})))
+
+(fn p [style ?text] (lume.merge style {:pause-after true} (if ?text {:text ?text :style false} {})))
+(fn np [style ?text] (lume.merge style {:pause-after false} (if ?text {:text ?text :style false} {})))
 
 (fn bgimg [filename] {:image filename :justify :center :overlay true :alpha 0.3 :topPadding 0})
 
@@ -151,7 +152,7 @@
       (openview #(MapEditView) {:pause-after true})
    {:target 180 :section "Branching Out"}]
   [h "Thanks!"
-  (openfile :neuttower/level6.fnl {:split :right :line 164})
+   (openfile :neuttower/level6.fnl {:split :right :line 164})
    (np **) "Questions?"
            {:topPadding 128}
            "Jeremy Penner"

ssc/hotswap.fnl

@@ -0,0 +1,112 @@
+; hotswap support
+(local {: addr-parser} (require :asm.65816))
+(local util (require :lib.util))
+(local {: bytes-to-uint16 : bytes-to-uint24 : int16-to-bytes : int24-to-bytes} util)
+
+; Hotswap theory:
+; The common case is code moving around in memory; even if you are not changing the content of code that
+; is currently executing, any changes to anything mean that pointers to that code will need to change.
+; If you try not to store pointers in globals (when everything is statically allocated, you should explicitly
+; name things, like in Forth) then the main place that persistent pointers to code exist is in call stacks -
+; specifically, the values on the stack consumed by "rts" or "rtl". When hotswapping, we need to walk the
+; callstack and A. find these values, and B. patch them to their new values. For this, we need to be able to
+; map any address that might be returned to from the old program to the new program - we can easily do this
+; by generating symbols for each callsite and setting up a reverse lookup table. We _also_ need to know the
+; stack layout at the time of each call so that we can find the next link in the chain, and to verify that
+; this hasn't changed (if the function has changed enough, then we can't modify it mid-execution).
+
+(fn assert-local-matches [funcname loc-old loc-new]
+  (each [_ key (ipairs [:type :name :returnaddr])]
+    (assert (= (. loc-old key) (. loc-new key)) (.. "Stack mismatch when patching " funcname))))
+
+(fn assert-locals-match [funcname locals-old locals-new]
+  (assert (= (length locals-old) (length locals-new)) (.. "Stack size mismatch when patching " funcname))
+  (each [iloc loc-old (ipairs locals-old)]
+    (assert-local-matches funcname loc-old (. locals-new iloc))))
+
+(fn next-callsite-offset [locals]
+  (var offset 0)
+  (var start-counting false)
+  (each [_ loc (ipairs locals)]
+    (if start-counting (let [size (match loc.type :placeholder 0 :word 2 :long 4)] (set offset (+ offset size)))
+        loc.returnaddr (set start-counting true)))
+  offset)
+
+(fn next-callsite-far? [locals]
+  (var far? false)
+  (each [_ loc (ipairs locals)]
+    (when (and loc.returnaddr (= loc.type :long))
+      (set far? true)))
+  far?)
+
+(fn read-callsite-addr [stack bank far]
+  (if far (bytes-to-uint24 stack 1) ; lowest byte (top of stack) is preserved B register
+          (bit.bor (bytes-to-uint16 stack) (bit.lshift bank 16))))
+
+(fn lookup-callsite [ssc addr]
+  (if (= addr (- (ssc.prg:lookup-addr :yield-forever) 1))
+      {:callsite-sym :yield-forever :locals [] :calling :yield-forever :funcname "<base task>"}
+    (. ssc.addr-to-callsite addr)))
+
+(fn patch-stack [ssc-old ssc-new stack bank far]
+  (if (= (length stack) 0) stack
+      ; top-of-stack should be a callsite; look it up
+    (let [callsite-addr (read-callsite-addr stack bank far)
+          {: callsite-sym : locals : funcname} (assert (lookup-callsite ssc-old callsite-addr)
+                                                 (.. "Top of stack value " callsite-addr " is not a recognized callsite"))
+          new-addr (- (ssc-new.prg:lookup-addr callsite-sym) 1)
+          {:locals new-locals} (lookup-callsite ssc-new  new-addr)
+          new-bank (bit.rshift new-addr 16)
+          _ (when (not far) (assert (= (bit.band callsite-addr 0xff0000) (bit.band new-addr 0xff0000))
+                              (.. funcname " moved banks from " bank " to " new-bank)))
+          _ (print (.. "patching " callsite-sym " from " callsite-addr " to " new-addr))
+          _ (assert-locals-match funcname locals new-locals)
+          new-top (if far (.. (stack:sub 1 1) (int24-to-bytes new-addr))
+                          (int16-to-bytes new-addr))
+          iaftertop (if far 5 3)
+          inextstack (+ iaftertop (next-callsite-offset locals))]
+      (.. new-top (stack:sub iaftertop (- inextstack 1))
+          (if (= funcname ssc-old.prg.start-symbol) (stack:sub inextstack) ; stop when we hit the boot-up function
+            (patch-stack ssc-old ssc-new (stack:sub inextstack) new-bank (next-callsite-far? locals)))))))
+
+(fn split-equally [s size]
+  (values (fn [s iprev] (let [i (+ iprev 1)
+                              istart (+ (* (- i 1) size) 1)
+                              iend (* i size)]
+                          (when (>= (length s) iend) (values i (s:sub istart iend)))))
+          s 0))
+
+(fn read-stacks [link ssc]
+  (let [stack-bounds-addr (ssc.prg:lookup-addr :first-task)
+        stack-bounds-bytes (link:read stack-bounds-addr 4)
+        first-task (bytes-to-uint16 stack-bounds-bytes)
+        last-task (bytes-to-uint16 stack-bounds-bytes 2)
+        task-size 0x100
+        read-size (+ (- last-task first-task) task-size)
+        task-count (/ read-size task-size)
+        task-bytes (link:read first-task read-size)
+        sp-offset (addr-parser ssc.TASK-STACK)]
+    (icollect [_ task (split-equally task-bytes task-size)]
+      (let [sp-addr (bytes-to-uint16 task sp-offset)
+            istackstart (bit.band sp-addr 0xff)
+            stack (task:sub (+ istackstart 2))]
+        {:sp-addr (+ sp-addr 1) : stack}))))
+
+(fn lookup-yield-bank [ssc] (bit.rshift (ssc.prg:lookup-addr :yield) 16))
+(fn filter-nonyielding-stacks [ssc stacks]
+  (let [yield-bank (lookup-yield-bank ssc)]
+    (icollect [_ stack (ipairs stacks)]
+      (let [callsite-addr (read-callsite-addr stack.stack yield-bank false)
+            callsite (lookup-callsite ssc callsite-addr)
+            funcname (?. callsite :calling)]
+        (when (= funcname :yield) stack)))))
+
+(fn hotswap-stacks [link ssc-old ssc-new]
+  (let [stacks (read-stacks link ssc-old)
+        yielding-stacks (filter-nonyielding-stacks ssc-old stacks)]
+    (collect [_ {: sp-addr : stack} (ipairs yielding-stacks)]
+      (let [(success new-stack) (pcall #(patch-stack ssc-old ssc-new stack (lookup-yield-bank ssc-old) false))]
+        (if success (values (tostring sp-addr) new-stack)
+          (error (.. new-stack ": stack at " (string.format "%X" sp-addr))))))))
+
+{: hotswap-stacks}

ssc/iigs/bootstub.fnl

@@ -0,0 +1,61 @@
+(import-macros {:sss ! : compile} :ssc.macros)
+(local link (require :link))
+
+#(compile $1
+   (start-symbol boot)
+   (predef-fn boot () void far)
+   (predef-fn [(or $2 :main)] () void far)
+
+   [(when (not= link.name :udpdebug) (! (do ;udpdebug boots into 16-bit mode
+     (start-symbol boot-8)
+     (org 0x1000)
+     (fn boot-8 ()
+       (asm (clc) (xce) (rep 0x30))  ; disable emulation mode, 16-bit index registers
+       (boot)
+       (asm (sec) (xce))) ; re-enter emulation mode
+   )))]
+
+   (org 0x060000)
+   (require ssc.iigs.toolbox)
+   (require ssc.task)
+
+   (global word BootUserID)
+   (global long BootHandle-00)
+   (global long BootHandle-01)
+   (global long BootHandle-e0)
+   (global long BootHandle-e1)
+   (global long BootHandle-06)
+
+   (far-fn boot ()
+     (save-dp-sp 0x0800)
+     (set-task-base 0x0800) ; space for 8 tasks
+     (save-6502-stack)
+
+     ; http://www.1000bit.it/support/manuali/apple/technotes/pdos/tn.pdos.27.html
+     ; When bootstrapping with no OS, we must reserve
+     (TLStartUp)
+     (LoadOneTool ToolsetMisc 0x0100)
+     (MTStartUp)
+     (set! BootUserID (GetNewID 0x1f00))
+
+     (LoadOneTool ToolsetMemoryManager 0x0100)
+     (set! BootHandle-06 (NewHandle 0xffff BootUserID 0xb017 0x060000))
+     (set! BootHandle-00 (NewHandle 0xb800 BootUserID 0xb017 0x000800))
+     (set! BootHandle-01 (NewHandle 0xb800 BootUserID 0xb017 0x010800))
+     (set! BootHandle-e0 (NewHandle 0x4000 BootUserID 0xb017 0xe02000))
+     (set! BootHandle-e1 (NewHandle 0x8000 BootUserID 0xb017 0xe12000))
+
+     ( [(or $2 :main)] )
+
+     (DisposeHandle BootHandle-e1)
+     (DisposeHandle BootHandle-e0)
+     (DisposeHandle BootHandle-01)
+     (DisposeHandle BootHandle-00)
+     (DisposeHandle BootHandle-06)
+     (DeleteID BootUserID)
+
+     (MTShutDown)
+
+     (restore-6502-stack)
+     (restore-dp-sp)))
+

ssc/iigs/graphics.fnl

@@ -0,0 +1,139 @@
+; IIgs graphical architecture:
+; PREMISE: All small-scale bitmapped graphics are encoded as code that pushes the graphics onto the stack,
+; which has been aligned to the appropriate place to draw said graphics.
+; Jump tables are stored in the main code segment so that eg. tiles can be easily calculated by index, and
+; so we don't have to explicitly pass longs to a regular function.
+
+(import-macros {:sss ! : compile} :ssc.macros)
+(local lume (require :lib.lume))
+(local {: countiter} (require :lib.util))
+
+; Our bitmap compiler is based on MrSprite - http://brutaldeluxe.fr/products/crossdevtools/mrspritetech/
+; sprite is a Lua string, where each byte is made up of two nibbles - the low nibble
+; should be a 16-bit value representing the colour, and the high nibble should be
+; 0 if the pixel is opaque, or f if the pixel is transparent.
+; width should be a multiple of 4.
+(fn preprocess-sprite [sprite w h]
+  ; splits up each horizontal line into two kinds of "runs":
+  ; :solid - each word can be directly written to memory; there is no transparency
+  ; :masked - the word at this location must be bitwise ANDed by :mask and ORed by :word
+  ; words containing nothing but transparent pixels are removed.
+  ; Also determines the most frequently-occurring solid words and distributes them
+  ; to registers.
+  (let [rows [] frequencies {}]
+    (var word 0)
+    (var mask 0)
+    (var isprite 1)
+    (for [y 0 (- h 1)]
+      (let [row []]
+        (var solidrun nil)
+        (for [x 0 (- w 1)]
+          (let [b (string.byte (sprite:sub isprite isprite))
+                pixcolour (bit.band b 0x0f)
+                pixmask (bit.rshift (bit.band b 0xf0) 4)
+                pixshift (match (% x 4) 0 4  1 0  2 12  3 8)]
+            (set word (bit.bor word (bit.lshift pixcolour pixshift)))
+            (set mask (bit.bor mask (bit.lshift pixmask pixshift)))
+            (when (= (% x 4) 3)
+              (when (not= mask 0) (set solidrun nil))
+              (when (= mask 0) ; fully opaque word
+                (when (= solidrun nil)
+                  (set solidrun {:run :solid :x (/ (- x 3) 2) :words []})
+                  (table.insert row solidrun))
+                (table.insert solidrun.words word)
+                (tset frequencies word (+ (or (. frequencies word) 0) 1)))
+              (when (and (not= mask 0) (not= mask 0xffff))
+                (table.insert row {:run :masked :x (/ (- x 3) 2) : word : mask}))
+              (set word 0)
+              (set mask 0))
+            (set isprite (+ isprite 1))))
+        (table.insert rows row)))
+    (local top-frequencies (icollect [word freq (pairs frequencies)] {: word : freq}))
+    (table.sort top-frequencies #(> $1.freq $2.freq))
+    {: rows
+     :registers {:x (?. top-frequencies 1 :word)
+                 :y (?. top-frequencies 2 :word)
+                 :d (?. top-frequencies 3 :word)}}))
+
+(fn compile-row [block row registers]
+  (each [_ run (ipairs row)]
+    (match run.run
+      :solid
+      (let [s-target (+ run.x (* (length run.words) 2) -1)]
+        (lume.push block [:tsc] [:adc (- s-target registers.s)] [:tcs])
+        (set registers.s (- run.x 1))
+        (for [iword (length run.words) 1 -1]
+          (lume.push block
+                     (match (. run.words iword)
+                       registers.x [:phx]
+                       registers.y [:phy]
+                       registers.d [:phd]
+                       word [:pea word]))))
+      :masked
+      (do (var s-offset (- run.x registers.s))
+          (when (> s-offset 127)
+            (lume.push block [:tsc] [:adc s-offset] [:tcs])
+            (set registers.s run.x)
+            (set s-offset 0))
+          (lume.push block [:lda s-offset :s] [:and run.mask] [:ora run.word] [:sta s-offset :s])))))
+
+(fn compile-sprite [sprite w h]
+  (let [{: rows : registers} (preprocess-sprite sprite w h)
+        block (lume.concat [:block]
+                           (when registers.x [[:ldx registers.x]])
+                           (when registers.y [[:ldy registers.y]])
+                           (when registers.d [[:lda registers.d] [:tcd]]))]
+    (set registers.s 0)
+    (each [_ row (ipairs rows)]
+      (compile-row block row registers)
+      (set registers.s (- registers.s 160)))
+    block))
+
+#(compile $1
+  (fn enable-shadow-writes ()  (set! (word-at (ref :0xc035)) (& (word-at (ref :0xc035)) 0xfff1)))
+  (fn disable-shadow-writes () (set! (word-at (ref :0xc035)) (| (word-at (ref :0xc035)) 0x000e)))
+
+  ; The fastest way to draw any graphics on the IIgs is to map the stack pointer to
+  ; video memory, and use stack-pushing instructions to write values. draw-object
+  ; takes a location in video memory and a pointer to a machine code routine called a "drawfn"
+  ; that performs the drawing
+  (global word draw-object-saved-stack 0)
+  (fn draw-object (screen object)
+    (asm (sei)  ; disable interrupts
+         (lda object) (sta [{:abs #(+ ($1:lookup-addr :draw-object-current-object-jump) 1)}]) ; self-modifying code! rewrite the jump target
+         (phd) ; save direct page register
+         (tsc) (sta draw-object-saved-stack) ; save stack
+         (lda screen 2) ; we offset by 2 because we just pushed a word onto the stack and the compiler doesn't know about it
+         (tcs) ; drawfns expect the current screen pointer to be stored in the stack register
+         (lda :0xc068) (ora 0x30) (sta :0xc068) ; move bank 1 to bank 0
+         (clc) ; clear carry - all drawfns will add to the stack pointer and then walk it back
+      draw-object-current-object-jump
+         (jmp draw-object) ; will actually jump to "object"
+      draw-object-finished (export draw-object-finished)
+         (lda :0xc068) (and 0xffcf) (sta :0xc068) ; move bank 1 back to bank 1
+         (lda draw-object-saved-stack) (tcs) ; restore the stack pointer
+         (pld) ; restore direct page register
+         (cli))) ; enable interrupts
+
+  (macrobarrier drawfn)
+  (form drawfn [(lambda [ssc name ...]
+    (let [expr (lume.concat [:do ...] [[:asm [:jmp :draw-object-finished]]])]
+      (ssc:define-fn name nil #(do
+        (local fname (.. "<drawfn " name ">"))
+        (local asm (ssc:expr-poly expr))
+        (ssc:expr-poly [:form name (fn [ssc] (assert (= ssc.locals nil) (.. name " must be called from a drawfn")) [:jmp fname])])
+        (ssc:expr-poly [:define name [:ref fname]])
+        (ssc.org:append fname asm)))))])
+
+  (drawfn pei-slam-tile
+    (asm (tsc) (tcd) (adc 7) (tcs)
+         [(lume.concat [:block] (icollect [_ (countiter 16)]
+            [(! block (pei (:d6)) (pei (:d4)) (pei (:d2)) (pei (:d0))
+                      (tsc) (adc 161) (tcd) (adc 7) (tcs))]))]))
+
+  (drawfn pei-slam-scanline
+    (asm (tsc) (tcd) (adc 159) (tcs)
+         [(lume.concat [:block] (icollect [offset (countiter 158 0 -2)] [:pei [(.. :d offset)]]))]))
+
+  (form compile-sprite [(lambda [ssc name sprite w h] (ssc:expr-poly [:drawfn name [:asm (compile-sprite sprite w h)]]))])
+)

ssc/iigs/toolbox.fnl

@@ -0,0 +1,458 @@
+(import-macros {:sss ! : compile} :ssc.macros)
+(local lume (require :lib.lume))
+(local util (require :lib.util))
+(local {: pairoff} util)
+
+#(compile $1 (do
+  (form def-toolbox [
+    (fn [ssc cmd name args return-type]
+      (let [call (fn [ssc ...]
+                   (let [arg-count (select :# ...)
+                         expected-arg-count (length args)
+                         expected-resultptr (= (type return-type) :number)
+                         expected-arg-count (if expected-resultptr (+ expected-arg-count 1) expected-arg-count)
+                         resultptr (when expected-resultptr (select expected-arg-count ...))
+                         error-handler (when (= arg-count (+ expected-arg-count 1)) (select (+ expected-arg-count 1) ...))
+                         expected-arg-count (if error-handler (+ expected-arg-count 1) expected-arg-count)
+                         block [:block]
+                         iloc-resultptr (do (assert (= arg-count expected-arg-count) (.. name " expected " expected-arg-count " args, got " (fv [...])))
+                                            (when resultptr
+                                              (lume.push block (ssc:push nil resultptr :word))
+                                              (length ssc.locals)))]
+                     (for [_ 1 (match return-type :void 0 :word 1 :long 2 _ return-type)]
+                       (lume.push block (ssc:push nil nil :register)))
+                     (each [_ push (ipairs (ssc:push-arguments (ssc:parse-parameters args) (lume.slice [...] 1 (length args))))]
+                       (lume.push block push))
+                     (lume.push block [:ldx cmd] [:jsr :0xe10000])
+                     (ssc:was-dropped (length args))
+                     (when error-handler
+                       (lume.push block [:bcc :-no-error-]
+                                        (ssc:push :error nil :register) (ssc:expr-poly error-handler) (ssc:drop :error)
+                                        :-no-error-))
+                     (match return-type
+                       :void nil
+                       :word (lume.push block (ssc:pop) nil)
+                       :long (lume.push block (ssc:pop) [:sta ssc.LONG_LO] (ssc:pop) [:sta ssc.LONG_HI])
+                       _     (do (lume.push block [:ldy 0])
+                                       (for [i 1 return-type]
+                                         (lume.push block (ssc:pop) [:sta [(ssc:local-offset iloc-resultptr) :s] :y])
+                                         (when (< i return-type) (lume.push block [:iny] [:iny])))
+                                       (lume.push block (ssc:drop))))
+                     (values block (if (= (type return-type) :string) return-type :void))))]
+      (ssc:expr-poly [:form name call])))])
+
+  (form tooltable [(fn [ssc name ...]
+    (ssc.org:append name [:dw (/ (select :# ...) 2)])
+    (each [_ toolset-id version (pairoff [...])]
+      (ssc.org:append [:dw (match (type toolset-id) :number toolset-id :string (. ssc.constants toolset-id))]
+                      [:dw version])))])
+
+  (define ToolsetToolLocator 0x01)
+  (def-toolbox 0x0201 TLStartUp () void)
+  (def-toolbox 0x0301 TLShutDown () void)
+  (def-toolbox 0x0401 TLVersion () word)
+  (def-toolbox 0x0b01 GetFuncPtr (userOrSystem funcNumTsNum) long)
+  (def-toolbox 0x0f01 LoadOneTool (toolNumber minVersion) void)
+  (def-toolbox 0x0e01 LoadTools ((long toolTablePtr)) void)
+  (def-toolbox 0x1501 MessageCenter (action type (long messageHandle)) void)
+  (def-toolbox 0x1401 RestoreTextState ((long stateHandle)) void)
+  (def-toolbox 0x1301 SaveTextState () long)
+  (def-toolbox 0x1101 TLMountVolume (whereX whereY (long line1ptr) (long line2ptr) (long but1ptr) (long but2ptr)) word)
+  (def-toolbox 0x1201 TLTextMountVolume ((long line1Ptr) (long line2Ptr) (long button1Ptr) (long button2Ptr)) word)
+  (def-toolbox 0x1001 UnloadOneTool (toolNumber) void)
+
+  (define ToolsetIntegerMath 0x0b)
+  (def-toolbox 0x020b IMStartUp () void)
+  (def-toolbox 0x030b IMShutDown () void)
+  (def-toolbox 0x040b IMVersion () word)
+  (def-toolbox 0x060b IMStatus () word)
+  (def-toolbox 0x280b Dec2Int ((long strPtr) strLength signedFlag) word)
+  (def-toolbox 0x290b Dec2Long ((long strPtr) strLength signedFlag) long)
+  (def-toolbox 0x1c0b Fix2Frac ((long fixedValue)) long)
+  (def-toolbox 0x1b0b Fix2Long ((long fixedValue)) long)
+  (def-toolbox 0x1e0b Fix2X ((long fixedValue) (long extendPtr)) void)
+  (def-toolbox 0x170b FixATan2 ((long input1) (long input2)) long)
+  (def-toolbox 0x110b FixDiv ((long dividend) (long divisor)) long)
+  (def-toolbox 0x0f0b FixMul ((long multiplicand) (long multiplier)) long)
+  (def-toolbox 0x0e0b FixRatio (numerator denominator) long)
+  (def-toolbox 0x130b FixRound ((long fixedValue)) word)
+  (def-toolbox 0x1d0b Frac2Fix ((long fracValue)) long)
+  (def-toolbox 0x1f0b Frac2X ((long fracValue) (long extendPtr)) void)
+  (def-toolbox 0x150b FracCos ((long angle)) long)
+  (def-toolbox 0x120b FracDiv ((long dividend) (long divisor)) long)
+  (def-toolbox 0x100b FracMul ((long multiplicand) (long multiplier)) long)
+  (def-toolbox 0x160b FracSin ((long angle)) long)
+  (def-toolbox 0x140b FracSqrt ((long fracValue)) long)
+  (def-toolbox 0x240b Hex2Int ((long strPtr) strLength) word)
+  (def-toolbox 0x250b Hex2Long ((long strPtr) strLength) long)
+  (def-toolbox 0x2a0b HexIt (intValue) long)
+  (def-toolbox 0x180b HiWord ((long longValue)) word)
+  (def-toolbox 0x260b Int2Dec (wordValue (long strPtr) strLength signedFlag) void)
+  (def-toolbox 0x220b Int2Hex (intValue (long strPtr) strLength) void)
+  (def-toolbox 0x270b Long2Dec ((long longValue) (long strPtr) strLength signedFlag) void)
+  (def-toolbox 0x1a0b Long2Fix ((long longIntValue)) long)
+  (def-toolbox 0x230b Long2Hex ((long longValue) (long strPtr) strLength) void)
+  (def-toolbox 0x0d0b LongDivide ((long dividend) (long divisor)) 4) ; -> long remainder, long quotient
+  (def-toolbox 0x0c0b LongMul ((long multiplicand) (long multiplier)) 4) ; -> long msResult, long lsResult
+  (def-toolbox 0x190b LoWord ((long longValue)) word)
+  (def-toolbox 0x090b Multiply (multiplicand multiplier) long)
+  (def-toolbox 0x0a0b SDivide (dividend divisor) long) ; -> word remainder, word quotient
+  (def-toolbox 0x0b0b UDivide (dividend divisor) long) ; -> word remainder, word quotient
+  (def-toolbox 0x200b X2Fix ((long extendPtr)) long)
+  (def-toolbox 0x210b X2Frac ((long extendPtr)) long)
+
+  (define ToolsetMemoryManager 0x02)
+  (def-toolbox 0x0202 MMStartUp () word)
+  (def-toolbox 0x0302 MMShutDown (userID) void)
+  (def-toolbox 0x0402 MMVersion () word)
+  (def-toolbox 0x0602 MMStatus () word)
+  (def-toolbox 0x2b02 BlockMove ((long sourcePtr) (long destPtr) (long count)) void)
+  (def-toolbox 0x1e02 CheckHandle ((long theHandle)) void)
+  (def-toolbox 0x1f02 CompactMem () void)
+  (def-toolbox 0x1102 DisposeAll (userID) void)
+  (def-toolbox 0x1002 DisposeHandle ((long theHandle)) void)
+  (def-toolbox 0x1a02 FindHandle ((long locationPtr)) long)
+  (def-toolbox 0x1b02 FreeMem () long)
+  (def-toolbox 0x1802 GetHandleSize ((long theHandle)) long)
+  (def-toolbox 0x2a02 HandToHand ((long sourceHandle) (long destHandle) (long count)) void)
+  (def-toolbox 0x2902 HandToPtr ((long sourceHandle) (long destPtr) (long count)) void)
+  (def-toolbox 0x2002 HLock ((long theHandle)) void)
+  (def-toolbox 0x2102 HLockAll (userID) void)
+  (def-toolbox 0x2202 HUnlock ((long theHandle)) void)
+  (def-toolbox 0x2302 HUnlockAll (userID) void)
+  (def-toolbox 0x1c02 MaxBlock () long)
+  (def-toolbox 0x0902 NewHandle ((long blockSize) userID attributes (long locationPtr)) long)
+  (def-toolbox 0x2802 PtrToHand ((long sourcePtr) (long destHandle) (long count)) void)
+  (def-toolbox 0x1302 PurgeAll (userID) void)
+  (def-toolbox 0x1202 PurgeHandle ((long theHandle)) void)
+  (def-toolbox 0x0a02 ReAllocHandle ((long blockSize) userID attributes (long locationPtr) (long theHandle)) void)
+  (def-toolbox 0x0b02 RestoreHandle ((long theHandle)) void)
+  (def-toolbox 0x1902 SetHandleSize ((long newSize) (long theHandle)) void)
+  (def-toolbox 0x2402 SetPurge ((long theHandle)) word)
+  (def-toolbox 0x2502 SetPurgeAll (userID newPurgeLevel) void)
+  (def-toolbox 0x1d02 TotalMem () long)
+
+  (define ToolsetText 0x0c)
+  (def-toolbox 0x020c TextStartUp () void)
+  (def-toolbox 0x030c TextShutDown () void)
+  (def-toolbox 0x040c TextVersion () word)
+  (def-toolbox 0x060c TextStatus () word) ; -> activeFlag
+  (def-toolbox 0x160c CtlTextDev (deviceNum controlCode) void)
+  (def-toolbox 0x1f0c ErrWriteBlock ((long textPtr) offset count) void)
+  (def-toolbox 0x190c ErrWriteChar (theChar) void)
+  (def-toolbox 0x210c ErrWriteCString ((long cStrPtr)) void)
+  (def-toolbox 0x1b0c ErrWriteLine ((long strPtr)) void)
+  (def-toolbox 0x1d0c ErrWriteString ((long strPtr)) void)
+  (def-toolbox 0x0e0c GetErrGlobals () long) ; -> word andMask, word orMask
+  (def-toolbox 0x140c GetErrorDevice () 3) ; -> word deviceType, long ptrOrSlot
+  (def-toolbox 0x0c0c GetInGlobals () long) ; -> word andMask, word orMask
+  (def-toolbox 0x120c GetInputDevice () 3) ; -> word deviceType, long ptrOrSlot
+  (def-toolbox 0x0d0c GetOutGlobals () long) ; -> word andMask, word orMask
+  (def-toolbox 0x130c GetOutputDevice () 3) ; -> word deviceType, long ptrOrSlot
+  (def-toolbox 0x150c InitTextDev (deviceNum) void)
+  (def-toolbox 0x220c ReadChar (echoFlag) word)
+  (def-toolbox 0x240c ReadLine ((long bufferPtr) maxCount eolChar echoFlag) word)
+  (def-toolbox 0x0b0c SetErrGlobals (andMask orMask) void)
+  (def-toolbox 0x110c SetErrorDevice (deviceType (long ptrOrSlot)) void)
+  (def-toolbox 0x090c SetInGlobals (andMask orMask) void)
+  (def-toolbox 0x0f0c SetInputDevice (deviceType (long ptrOrSlot)) void)
+  (def-toolbox 0x0a0c SetOutGlobals (andMask orMask) void)
+  (def-toolbox 0x100c SetOutputDevice (deviceType ptrOrSlot) void)
+  (def-toolbox 0x170c StatusTextDev (deviceNum requestCode) void)
+  (def-toolbox 0x230c TextReadBlock ((long bufferPtr) offset blockSize echoFlag) void)
+  (def-toolbox 0x1e0c TextWriteBlock ((long textPtr) offset count) void)
+  (def-toolbox 0x180c WriteChar (theChar) void)
+  (def-toolbox 0x200c WriteCString ((long cStrPtr)) void) ; ptr cStrPtr
+  (def-toolbox 0x1a0c WriteLine ((long strPtr)) void)
+  (def-toolbox 0x1c0c WriteString ((long strPtr)) void)
+
+  (define ToolsetMisc 0x03)
+  (def-toolbox 0x0203 MTStartUp () void)
+  (def-toolbox 0x0303 MTShutDown () void)
+  (def-toolbox 0x0403 MTVersion () word)
+  (def-toolbox 0x0603 MTStatus () word)
+  (def-toolbox 0x0903 WriteBRam ((long bufferPtr)) void)
+  (def-toolbox 0x0a03 ReadBRam ((long bufferPTr)) void)
+  (def-toolbox 0x0b03 WriteBParam (theData paramRefNum) void)
+  (def-toolbox 0x0c03 ReadBParam (paramRefNum) word)
+  (def-toolbox 0x0d03 ReadTimeHex () 4) ; -> bytes: weekDay, null, month, day, curYear, hour, minute, second
+  (def-toolbox 0x0e03 WriteTimeHex (month-day curYear-hour mintue-second) void)
+  (def-toolbox 0x0f03 ReadAsciiTime ((long bufferPtr)) void)
+  (def-toolbox 0x2403 FWEntry (aRegValue xRegValue yRegValue eModeEntryPt) 4) ; words: status, aRegExit, xRegExit, yRegExit
+  (def-toolbox 0x1603 GetAddr (refNum) long)
+  (def-toolbox 0x2503 GetTick () long)
+  (def-toolbox 0x2904 GetIRQEnable () word)
+  (def-toolbox 0x2303 IntSource (srcRefNum) void)
+  (def-toolbox 0x1c03 ClampMouse (xMinCLamp xMaxClamp yMinClamp yMaxClamp) void)
+  (def-toolbox 0x1b03 ClearMouse () void)
+  (def-toolbox 0x1d03 GetMouseClamp () 4) ; words: xMinCLamp, xMaxClamp, yMinClamp, yMaxClamp
+  (def-toolbox 0x1a03 HomeMouse () void)
+  (def-toolbox 0x1803 InitMouse (mouseSlot) void)
+  (def-toolbox 0x1e03 PosMouse (xPos yPos) void)
+  (def-toolbox 0x1704 ReadMouse () 3) ; xPosition, yPosition, byte status, byte mode
+  (def-toolbox 0x1f03 ServeMouse () word)
+  (def-toolbox 0x1903 SetMouse (mouseMode) void)
+  (def-toolbox 0x2a03 SetAbsClamp (xMinClamp xMaxClamp yMinClamp yMaxClamp) void)
+  (def-toolbox 0x2b03 GetAbsClamp () 4) ; xMinClamp xMaxClamp yMinClamp yMaxClamp
+  (def-toolbox 0x2603 PackBytes ((long startHandle) (long sizePtr) (long bufferPtr) bufferSize) word)
+  (def-toolbox 0x2703 UnPackBytes ((long bufferPtr) bufferSize (long startHandle) (long sizePtr)) word)
+  (def-toolbox 0x2803 Munger ((long destPtr) (long destLenPtr) (long targPtr) targLEn (long replPtr) replLen (long padPtr)) word)
+  (def-toolbox 0x1203 SetHeartBeat ((long taskPtr)) void)
+  (def-toolbox 0x1303 DelHeartBeat ((long taskPtr)) void)
+  (def-toolbox 0x1403 ClrHeartBeat () void)
+  (def-toolbox 0x2c03 SysBeep () void)
+  (def-toolbox 0x1503 SysFailMgr (errorCode (long strPtr)) void)
+  (def-toolbox 0x2003 GetNewID (idTag) word)
+  (def-toolbox 0x2103 DeleteID (idTag) void)
+  (def-toolbox 0x2203 StatusID (idTag) void)
+  (def-toolbox 0x1003 SetVector (vectorRefNum (long vectorPtr)) void)
+  (def-toolbox 0x1103 GetVector (vectorRefNum) long)
+
+  (define ToolsetEventManager 0x06)
+  (define nullEvt 0)
+  (define mouseDownEvt 1)
+  (define mouseUpEvt 2)
+  (define keyDownEvt 3)
+  (define autoKeyEvt 5)
+  (define updateEvt 6)
+  (define activeFlag 0x0001)
+  (define changeFlag 0x0002)
+  (define btn1State 0x0040)
+  (define btn0State 0x0080)
+  (define appleKey 0x0100)
+  (define shiftKey 0x0200)
+  (define capsLock 0x0400)
+  (define optionKey 0x0800)
+  (define controlKey 0x1000)
+  (define keyPad 0x2000)
+  (define mDownMask 0x0002)
+  (define mUpMask 0x0004)
+  (define keyDownMask 0x0008)
+  (define autoKeyMask 0x0020)
+  (define updateMask 0x0040)
+  (def-toolbox 0x0206 EMStartUp (dPageAddr queueSize xMinClamp xMaxClamp yMinClamp yMaxClamp userID) void)
+  (def-toolbox 0x0306 EMShutDown () void)
+  (def-toolbox 0x0406 EMVersion () word)
+  (def-toolbox 0x0606 EMStatus () word)
+  (def-toolbox 0x0d06 Button (buttonNum) word)
+  (def-toolbox 0x0b06 EventAvail (eventMask (long eventPtr)) word)
+  (def-toolbox 0x1506 FlushEvents (eventMask stopMask) word)
+  (def-toolbox 0x1206 GetCaretTime () long)
+  (def-toolbox 0x1106 GetDblTime () long)
+  (def-toolbox 0x0c06 GetMouse ((long mouseLocPtr)) void)
+  (def-toolbox 0x0a06 GetNextEvent (eventMask (long eventPtr)) word)
+  (def-toolbox 0x1606 GetOSEvent (eventMask (long eventPtr)) word)
+  (def-toolbox 0x1706 OSEventAvail (eventMask (long eventPtr)) word)
+  (def-toolbox 0x1406 PostEvent (eventCode (long eventMsg)) word)
+  (def-toolbox 0x1806 SetEventMask (sysEventMask) void)
+  (def-toolbox 0x0e06 StillDown (buttonNum) word)
+  (def-toolbox 0x1006 TickCount () long)
+  (def-toolbox 0x0f06 WaitMouseUp (buttonNum) word)
+
+  (define ToolsetQuickDraw 0x04)
+  (def-toolbox 0x0204 QDStartUp (dPageAddr masterSCB maxWidth userID) void)
+  (def-toolbox 0x0304 QDShutDown () void)
+  (def-toolbox 0x0404 QDVersion () word)
+  (def-toolbox 0x0604 QDStatus () word)
+  (def-toolbox 0x8004 AddPt ((long srcPtPtr) (long destPtPtr)) void)
+  (def-toolbox 0xac04 CharBounds (theChar (long resultPtr)) void)
+  (def-toolbox 0xa804 CharWidth (theChar) word)
+  (def-toolbox 0x1504 ClearScreen (colorWord) void)
+  (def-toolbox 0x2604 ClipRect ((long rectPtr)) void)
+  (def-toolbox 0xc204 ClosePoly () void)
+  (def-toolbox 0x1a04 ClosePort ((long portPtr)) void)
+  (def-toolbox 0x6e04 CloseReg ((long rgnHandle)) void)
+  (def-toolbox 0x6904 CopyRgn ((long srcRgnHandle) (long dstRgnHandle)) void)
+  (def-toolbox 0xae04 CStringBounds ((long cStringPtr) (long resultPtr)) void)
+  (def-toolbox 0xaa04 CStringWidth ((long cStringPtr)) word)
+  (def-toolbox 0x7304 DiffRgn ((long rgn1Handle) (long rgn2Handle) (long diffRgnHandle)) void)
+  (def-toolbox 0x6804 DisposeRgn ((long rgnHandle)) void)
+  (def-toolbox 0xa404 DrawChar (theChar) void)
+  (def-toolbox 0xa604 DrawCString ((long cStringPtr)) void)
+  (def-toolbox 0xa504 DrawString ((long stringPtr)) void)
+  (def-toolbox 0xa704 DrawText ((long textPtr) textLength) void)
+  (def-toolbox 0x7804 EmptyRgn ((long rgnHandle)) word)
+  (def-toolbox 0x8304 EqualPt ((long point1Ptr) (long point2Ptr)) word)
+  (def-toolbox 0x5104 EqualRect ((long rect1Ptr) (long rect2Ptr)) word)
+  (def-toolbox 0x7704 EqualRgn ((long rgn1Handle) (long rgn2Handle)) word)
+  (def-toolbox 0x6404 EraseArc ((long rectPtr) startAngle arcAngle) void)
+  (def-toolbox 0x5a04 EraseOval ((long rectPtr)) void)
+  (def-toolbox 0xbe04 ErasePoly ((long polyHandle)) void)
+  (def-toolbox 0x5504 EraseRect ((long rectPtr)) void)
+  (def-toolbox 0x7b04 EraseRgn ((long rgnHandle)) void)
+  (def-toolbox 0x5f04 EraseRRect ((long rectPtr) ovalWidth ovalHeight) void)
+  (def-toolbox 0x6604 FillArc ((long rectPtr) startAngle arcAngle (long patternPtr)) void)
+  (def-toolbox 0x5c04 FillOval ((long rectPtr) (long patternPtr)) void)
+  (def-toolbox 0xc004 FillPoly ((long polyHandle) (long patternPtr)) void)
+  (def-toolbox 0x5704 FillRect ((long rectPtr) (long patternPtr)) void)
+  (def-toolbox 0x7d04 FillRgn ((long rgnHandle) (long patternPtr)) void)
+  (def-toolbox 0x6104 FillRRect ((long rectPtr) ovalWidth ovalHeight (long patternPtr)) void)
+  (def-toolbox 0xcc04 ForceBufDims (maxWidth maxFontHeight maxFBRExtent) void)
+  (def-toolbox 0x6204 FrameArc ((long rectPtr) startAngle arcAngle) void)
+  (def-toolbox 0x5804 FrameOval ((long rectPtr)) void)
+  (def-toolbox 0xbc04 FramePoly ((long polyHandle)) void)
+  (def-toolbox 0x5304 FrameRect ((long rectPtr)) void)
+  (def-toolbox 0x7904 FrameRgn ((long rgnHandle)) void)
+  (def-toolbox 0x5d04 FrameRRect ((long rectPtr) ovalWidth ovalHeight) void)
+  (def-toolbox 0x0904 GetAddress (tableID) long)
+  (def-toolbox 0xb104 GetArcRot () word)
+  (def-toolbox 0xa304 GetBackColor () word)
+  (def-toolbox 0x3504 GetBackPat ((long patternPtr)) void)
+  (def-toolbox 0xd504 GetCharExtra () long)
+  (def-toolbox 0x2504 GetClip ((long rgnHandle)) void)
+  (def-toolbox 0xc704 GetClipHandle () long)
+  (def-toolbox 0x1104 GetColorEntry (tableNumber entryNumber) word)
+  (def-toolbox 0x0f04 GetColorTable (tableNumber (long destTablePtr)) void)
+  (def-toolbox 0x8f04 GetCursorAdr () long)
+  (def-toolbox 0xcf04 GetFGSize () word)
+  (def-toolbox 0x9504 GetFont () long)
+  (def-toolbox 0x9904 GetFontFlags () word)
+  (def-toolbox 0x9704 GetFontGlobals ((long fgRecPtr)) void)
+  (def-toolbox 0xd104 GetFontID () long)
+  (def-toolbox 0x9604 GetFontInfo ((long fontInfoRecPtr)) void)
+  (def-toolbox 0xd904 GetFontLore ((long recordPtr) recordSize) word)
+  (def-toolbox 0xa104 GetForeColor () word)
+  (def-toolbox 0x4504 GetGrafProcs () long)
+  (def-toolbox 0x1704 GetMasterSCB () word)
+  (def-toolbox 0x2904 GetPen () long)
+  (def-toolbox 0x3304 GetPenMask ((long maskPtr)) void)
+  (def-toolbox 0x2f04 GetPenMode () word)
+  (def-toolbox 0x3104 GetPenPat ((long patternPtr)) void)
+  (def-toolbox 0x2d04 GetPenSize ((long pointPtr)) void)
+  (def-toolbox 0x2b04 GetPenState ((long penStatePtr)) void)
+  (def-toolbox 0x3f04 GetPicSave () long)
+  (def-toolbox 0x8804 GetPixel (h v) word)
+  (def-toolbox 0x4304 GetPolySave () long)
+  (def-toolbox 0x1c04 GetPort () long)
+  (def-toolbox 0x1e04 GetPortLoc ((long locInfoPtr)) void)
+  (def-toolbox 0x2004 GetPortRect ((long rectPtr)) void)
+  (def-toolbox 0x4104 GetRgnSave () long)
+  (def-toolbox 0xd804 GetRomFont ((long recordPtr)) void)
+  (def-toolbox 0x1304 GetSCB (scanLine) word)
+  (def-toolbox 0x9f04 GetSpaceExtra () long)
+  (def-toolbox 0x0c04 GetStandardSCB () word)
+  (def-toolbox 0x4904 GetSysField () long)
+  (def-toolbox 0xb304 GetSysFont () long)
+  (def-toolbox 0x9b04 GetTextFace () word)
+  (def-toolbox 0x9d04 GetTextMode () word)
+  (def-toolbox 0xd304 GetTextSize () word)
+  (def-toolbox 0x4704 GetUserField () long)
+  (def-toolbox 0xc904 GetVisHandle () long)
+  (def-toolbox 0xb504 GetVisRgn ((long rgnHandle)) void)
+  (def-toolbox 0x8504 GlobalToLocal ((long pointPtr)) void)
+  (def-toolbox 0x0b04 GrafOff () void)
+  (def-toolbox 0x0a04 GrafOn () void)
+  (def-toolbox 0x9004 HideCursor () void)
+  (def-toolbox 0x2704 HidePen () void)
+  (def-toolbox 0xd704 InflateTextBuffer (newWidth newHeight) void)
+  (def-toolbox 0x0d04 InitColorTable ((long tablePtr)) void)
+  (def-toolbox 0xca04 InitCursor () void)
+  (def-toolbox 0x1904 InitPort ((long portPtr)) void)
+  (def-toolbox 0x4c04 InsetRect ((long rectPtr) dH dV) void)
+  (def-toolbox 0x7004 InsetRgn ((long rgnHandle) dH dV) void)
+  (def-toolbox 0x6504 InvertArc ((long rectPtr) startAngle arcAngle) void)
+  (def-toolbox 0x5b04 InvertOval ((long rectPtr)) void)
+  (def-toolbox 0xbf04 InvertPoly ((long polyHandle)) void)
+  (def-toolbox 0x5604 InvertRect ((long rectPtr)) void)
+  (def-toolbox 0x7c04 InvertRgn ((long rgnHandle)) void)
+  (def-toolbox 0x6004 InvertRRect ((long rectPtr) ovalWidth ovalHeight) void)
+  (def-toolbox 0xc304 KillPoly ((long polyHandle)) void)
+  (def-toolbox 0x3d04 Line (dH dV) void)
+  (def-toolbox 0x3c04 LineTo (h v) void)
+  (def-toolbox 0x8404 LocalToGlobal ((long pointPtr)) void)
+  (def-toolbox 0xc504 MapPoly ((long polyHandle) (long srcRectPtr) (long destRectPtr)) void)
+  (def-toolbox 0x8a04 MapPt ((long pointPtr) (long srcRectPtr) (long destRectPtr)) void)
+  (def-toolbox 0x8b04 MapRect ((long rectPtr) (long srcRectPtr) (long destRectPtr)) void)
+  (def-toolbox 0x8c04 MapRgn ((long mapRgnHandle) (long srcRectPtr) (long destRectPtr)) void)
+  (def-toolbox 0x3b04 Move (dH dV) void)
+  (def-toolbox 0x2204 MovePortTo (h v) void)
+  (def-toolbox 0x3a04 MoveTo (h v) void)
+  (def-toolbox 0x6704 NewRgn () long)
+  (def-toolbox 0x5204 NotEmptyRect ((long rectPtr)) word)
+  (def-toolbox 0x9204 ObscureCursor () void)
+  (def-toolbox 0xc404 OffsetPoly ((long polyHandle) dH dV) void)
+  (def-toolbox 0x4b04 OffsetRect ((long rectPtr) dH dV) void)
+  (def-toolbox 0x6f04 OffsetRgn ((long rgnHandle) dH dV) void)
+  (def-toolbox 0xc104 OpenPoly () long)
+  (def-toolbox 0x1804 OpenPort ((long portPtr)) void)
+  (def-toolbox 0x6d04 OpenRgn () void)
+  (def-toolbox 0x6304 PaintArc ((long rectPtr) startAngle arcAngle) void)
+  (def-toolbox 0x5904 PaintOval ((long rectPtr)) void)
+  (def-toolbox 0x7f04 PaintPixels ((long paintParamPtr)) void)
+  (def-toolbox 0xbd04 PaintPoly ((long polyHandle)) void)
+  (def-toolbox 0x5404 PaintRect ((long rectPtr)) void)
+  (def-toolbox 0x7a04 PaintRgn ((long rgnHandle)) void)
+  (def-toolbox 0x5e04 PaintRRect ((long rectPtr) ovalWidth ovalHeight) void)
+  (def-toolbox 0x3604 PenNormal () void)
+  (def-toolbox 0xd604 PPToPort ((long srcLocPtr) (long srcRectPtr) destX destY transferMode) void)
+  (def-toolbox 0x5004 Pt2Rect ((long point1Ptr) (long point2Ptr) (long rectPtr)) void)
+  (def-toolbox 0x4f04 PtInRect ((long pointPtr) (long rectPtr)) word)
+  (def-toolbox 0x7504 PtInRgn ((long pointPtr) (long rgnHandle)) word)
+  (def-toolbox 0x8604 Random () word)
+  (def-toolbox 0x7604 RectInRgn ((long rectPtr) (long rgnHandle)) word)
+  (def-toolbox 0x6c04 RectRgn ((long rgnHandle) (long rectPtr)) void)
+  (def-toolbox 0xce04 RestoreBufDims ((long sizeInfoPtr)) void)
+  (def-toolbox 0xcd04 SaveBufDims ((long sizeInfoPtr)) void)
+  (def-toolbox 0x8904 ScalePt ((long pointPtr) (long srcRectPtr) (long destRectPtr)) void)
+  (def-toolbox 0x7e04 ScrollRect ((long rectPtr) dH dV (long updateRgnHandle)) void)
+  (def-toolbox 0x4d04 SectRect ((long rect1Ptr) (long rect2Ptr) (long intersectRectPtr)) word)
+  (def-toolbox 0x7104 SectRgn ((long rgn1Handle) (long rgn2Handle) (long destRgnHandle)) void)
+  (def-toolbox 0x1404 SetAllSCBs (newSCB) void)
+  (def-toolbox 0xb004 SetArcRot (arcRotValue) void)
+  (def-toolbox 0xa204 SetBackColor (backColor) void)
+  (def-toolbox 0x3404 SetBackPat ((long patternPtr)) void)
+  (def-toolbox 0xcb04 SetBufDims (maxWidth maxFontHeight maxFBRExtent) void)
+  (def-toolbox 0xd404 SetCharExtra ((long charExtra)) void)
+  (def-toolbox 0x2404 SetClip ((long rgnHandle)) void)
+  (def-toolbox 0xc604 SetClipHandle ((long rgnHandle)) void)
+  (def-toolbox 0x1004 SetColorEntry (tableNumber entryNUmber newColor) void)
+  (def-toolbox 0x0e04 SetColorTable (tableNumber (long srcTablePtr)) void)
+  (def-toolbox 0x8e04 SetCursor ((long cursorPtr)) void)
+  (def-toolbox 0x6a04 SetEmptyRgn ((long rgnHandle)) void)
+  (def-toolbox 0x9404 SetFont ((long newFontHandle)) void)
+  (def-toolbox 0x9804 SetFontFlags (fontFlags) void)
+  (def-toolbox 0xd004 SetFontID ((long fontID)) void)
+  (def-toolbox 0xa004 SetForeColor (foreColor) void)
+  (def-toolbox 0x4404 SetGrafProcs ((long grafProcsPtr)) void)
+  (def-toolbox 0xb604 SetIntUse (useInt) void)
+  (def-toolbox 0x1604 SetMasterSCB (masterSCB) void)
+  (def-toolbox 0x2304 SetOrigin (h v) void)
+  (def-toolbox 0x3204 SetPenMask ((long maskPtr)) void)
+  (def-toolbox 0x2e04 SetPenMode (penMode) void)
+  (def-toolbox 0x3004 SetPenPat ((long patternPtr)) void)
+  (def-toolbox 0x2c04 SetPenSize (penWidth penHeight) void)
+  (def-toolbox 0x2a04 SetPenState ((long penStatePtr)) void)
+  (def-toolbox 0x3e04 SetPicSave ((long picSaveValue)) void)
+  (def-toolbox 0x1b04 SetPort ((long portPtr)) void)
+  (def-toolbox 0x1d04 SetPortLoc ((long locInfoPtr)) void)
+  (def-toolbox 0x1f04 SetPortRect ((long rectPtr)) void)
+  (def-toolbox 0x2104 SetPortSize (portWidth portHeight) void)
+  (def-toolbox 0x8204 SetPt ((long srcPtPtr) h v) void)
+  (def-toolbox 0x8704 SetRandSeed ((long randomSeed)) void)
+  (def-toolbox 0x4a04 SetRect ((long rectPtr) left top right bottom) void)
+  (def-toolbox 0x6b04 SetRectRgn ((long rgnHandle) left top right bottom) void)
+  (def-toolbox 0x1204 SetSCB (scanLine newSCB) void)
+  (def-toolbox 0x3804 SetSolidBackPat (colorNum) void)
+  (def-toolbox 0x3704 SetSolidPenPat (colorNum) void)
+  (def-toolbox 0x9e04 SetSpaceExtra ((long spaceExtra)) void)
+  (def-toolbox 0x8d04 SetStdProcs ((long stdProcRecPtr)) void)
+  (def-toolbox 0xb204 SetSysFont ((long fontHandle)) void)
+  (def-toolbox 0x9a04 SetTextFace (textFace) void)
+  (def-toolbox 0x9c04 SetTextMode (textMode) void)
+  (def-toolbox 0xd204 SetTextSize (textSize) void)
+  (def-toolbox 0x4604 SetUserField ((long userFieldValue)) void)
+  (def-toolbox 0xc804 SetVisHandle ((long rgnHandle)) void)
+  (def-toolbox 0xb404 SetVisRgn ((long rgnHandle)) void)
+  (def-toolbox 0x9104 ShowCursor () void)
+  (def-toolbox 0x2804 ShowPen () void)
+  (def-toolbox 0x3904 SolidPattern (colorNum (long patternPtr)) void)
+  (def-toolbox 0xad04 StringBounds ((long stringPtr) (long resultPtr)) void)
+  (def-toolbox 0xa904 StringWidth ((long stringPtr)) word)
+  (def-toolbox 0x8104 SubPt ((long srcPtPtr) (long destPtPtr)) void)
+  (def-toolbox 0xaf04 TextBounds ((long textPtr) textLength (long resultPtr)) void)
+  (def-toolbox 0xab04 TextWidth ((long textPtr) textLength) word)
+  (def-toolbox 0x4e04 UnionRect ((long rect1Ptr) (long rect2Ptr) (long unionRectPtr)) void)
+  (def-toolbox 0x7204 UnionRgn ((long rgn1Handle) (long rgn2Handle) (long unionRgnHandle)) void)
+  (def-toolbox 0x7404 XorRgn ((long rgn1Handle) (long rgn2Handle) (long xorRgnHandle)) void)
+))
+

ssc/iigs/u2-debug.fnl

@@ -0,0 +1,142 @@
+(import-macros {:sss ! : compile} :ssc.macros)
+(local {: cmd : response} (require :link.udpdebug))
+
+; sudo route add -net 172.24.1.0/24 gw 192.168.2.25
+
+; -VEDRIVE
+; CAT,S1
+; BLOAD UDPDEBUG.SYSTEM, TSYS, A$2000
+; CALL-151
+; 2000S
+
+(local Ssc (require :ssc))
+
+(local ssc (Ssc))
+
+(compile ssc
+  (start-symbol boot-8)
+  (org 0x2000)
+  (fn boot-8 ()
+    (asm (clc) (xce) (rep 0x30)  ; disable emulation mode, 16-bit index registers
+         (jsr debug-server-loop)
+         (sec) (xce))) ; re-enter emulation mode
+
+  (require ssc.stdlib)
+  (require ssc.iigs.toolbox)
+
+  (macro out [#(! (WriteLine (far-ref (pstr [$2]))))])
+
+  (buffer hexbuf (cstr "    "))
+  (fn printnum (num)
+    (long! (ref hexbuf) (HexIt num))
+    (WriteCString (far-ref hexbuf)))
+
+  (require ssc.iigs.uthernet2)
+
+  (fn u2-init-debug-server ()
+    (out "Starting server")
+    (u2-reset)
+    (u2-udp-server-start 6502))
+
+  (buffer u2-debug-buffer 1500)
+
+  (predef-fn u2-debug-server-poll () void far)
+
+  (global word u2-debug-server-paused false)
+  (fn u2-debug-server-cmd-write (msgid)
+    (set! u2-debug-server-paused true)
+    (let (count (word-at (ref u2-debug-buffer)) index 2)
+      (printnum count) (out ": # of blocks to write")
+      (while (> count 0)
+        (let (addr (long-at (+ (ref u2-debug-buffer) index))
+              size (word-at (+ (ref u2-debug-buffer) index 4)))
+          (printnum (hiword addr)) (printnum (loword addr)) (printnum size) (out ": writing")
+          (memcpy (+ (far-ref u2-debug-buffer) index 6) addr size)
+          (set! index (+ index size 6))
+          (set! count (- count 1))))
+      (u2-tx-begin 2)
+      (u2-write msgid)
+      (u2-write [response.ack])
+      (u2-tx-complete)))
+
+  (fn u2-debug-server-cmd-read (msgid)
+    (let (index 6 totalsize 0 count (word-at (ref u2-debug-buffer)))
+      (printnum count) (out ": # of blocks to read")
+      (while (> count 0)
+        (let (size (word-at (+ (ref u2-debug-buffer) index)))
+          (set! totalsize (+ totalsize size))
+          (set! index (+ index 6))
+          (set! count (- count 1))))
+      (u2-tx-begin (+ totalsize 2))
+      (u2-write msgid)
+      (u2-write [response.data])
+      (set! count (word-at (ref u2-debug-buffer)))
+      (set! index 2)
+      (while (> count 0)
+        (let (addr (long-at (+ (ref u2-debug-buffer) index))
+              size (word-at (+ (ref u2-debug-buffer) index 4)))
+          (u2-write-farbuf addr size)
+          (set! index (+ index 6))
+          (set! count (- count 1))))
+      (u2-tx-complete)))
+
+  (fn u2-debug-server-cmd-exec (msgid)
+    (let (val (asm (jsr u2-debug-buffer))
+          longval (asm-long))
+      (u2-tx-begin 8)
+      (u2-write msgid)
+      (u2-write [response.data])
+      (u2-write-word val)
+      (u2-write-word (loword longval))
+      (u2-write-word (hiword longval))
+      (u2-tx-complete)))
+
+  (fn u2-debug-server-cmd-pause (msgid)
+    (set! u2-debug-server-paused (word-at (ref u2-debug-buffer)))
+    (u2-tx-begin 3)
+    (u2-write msgid)
+    (u2-write [response.ack])
+    (u2-write u2-debug-server-paused)
+    (u2-tx-complete)
+    (while u2-debug-server-paused
+      (u2-debug-server-poll)))
+
+  (fn u2-debug-server-cmd-ping (msgid)
+    (u2-tx-begin 2)
+    (u2-write msgid)
+    (u2-write [response.ack])
+    (u2-tx-complete))
+
+  (fn u2-debug-server-cmd (msgid cmd)
+    (if (= cmd [cmd.write]) (u2-debug-server-cmd-write msgid)
+        (= cmd [cmd.read])  (u2-debug-server-cmd-read msgid)
+        (= cmd [cmd.eval])  (u2-debug-server-cmd-exec msgid)
+        (= cmd [cmd.pause]) (u2-debug-server-cmd-pause msgid)
+        (= cmd [cmd.ping])  (u2-debug-server-cmd-ping msgid)))
+
+  (far-fn u2-debug-server-poll ()
+    (let (size (u2-rx-begin))
+      (when size
+        (let (msgid (u2-read)
+              cmd (u2-read))
+            (printnum msgid) (printnum cmd) (out ": Got message!")
+          (u2-read-buf (ref u2-debug-buffer) (- size 2))
+          (u2-rx-complete)
+          (u2-set-tx-dest u2-udp-recv-ip u2-udp-recv-port)
+          (u2-debug-server-cmd msgid cmd)))))
+
+  (fn debug-server-loop ()
+    (TextStartUp)
+    (IMStartUp)
+    (u2-init-debug-server)
+    (forever (u2-debug-server-poll)))
+)
+
+(let [Prodos (require :asm.prodos)
+      prg (ssc:assemble)
+      disk (Prodos "ProDOS_Blank.dsk")]
+  (disk:update-volume-header {:name "UDP.DEBUG"})
+  (disk:add-file "UDPDEBUG.SYSTEM" Prodos.file-type.SYS 0x2000 (. (prg:org 0x2000) :block :bytes))
+  (disk:write "UdpDebug.dsk"))
+
+ssc

ssc/iigs/uthernet2.fnl

@@ -0,0 +1,149 @@
+; uthernet ii driver
+(local config {
+  :gateway [172 24 1 1]
+  :netmask [255 255 255 0]
+  :ip [172 24 1 6]
+  :slot 3
+  :mac [0xAD 0xE9 0xA5 0x4A 0x6D 0x66]
+})
+
+(import-macros {:sss ! : compile} :ssc.macros)
+
+(fn reg [base] (tostring (+ base (* config.slot 16))))
+(let [U2-MODE (reg 0xc084)
+      U2-ADDR-HI (reg 0xc085)
+      U2-ADDR-LO (reg 0xc086)
+      U2-DATA (reg 0xc087)]
+  #(compile $1
+    (macro u2-addr! [#[:word! [:ref U2-ADDR-HI] [:byteswap $2]]])
+    (macro u2-read [#[:byte-at [:ref U2-DATA]]])
+    (macro u2-write [#[:byte! [:ref U2-DATA] $2]])
+    (fn u2-read-word ()
+      (let (hi (u2-read)
+            lo (u2-read))
+        (| (byteswap hi) lo)))
+    (fn u2-write-word (w)
+      (let (hi (& (byteswap w) 0xff)
+            lo (& w 0xff))
+        (u2-write hi)
+        (u2-write lo)))
+
+    (fn u2-read-buf (addr count)
+      (asm (lda count) (tax)
+           (ldy 0)
+           (sep 0x20)
+         loop
+           (lda [U2-DATA])
+           (sta (addr) y)
+           (iny)
+           (dex)
+           (bne loop)
+
+           (rep 0x20)))
+
+    (fn u2-write-buf (addr count)
+      (asm (lda count) (tax)
+           (ldy 0)
+           (sep 0x20)
+         loop
+           (lda (addr) y)
+           (sta [U2-DATA])
+           (iny)
+           (dex)
+           (bne loop)
+
+           (rep 0x20)))
+
+    (fn u2-write-farbuf ((long addr) count)
+      (asm (lda addr) (sta [$1.ADDR_LO])
+           (lda addr 2) (sta [$1.ADDR_HI])
+           (lda count) (tax)
+           (ldy 0)
+           (sep 0x20)
+         loop
+           (lda (([$1.ADDR_LO])) y)
+           (sta [U2-DATA])
+           (iny)
+           (dex)
+           (bne loop)
+
+           (rep 0x20)))
+
+    (asm u2-ipconfig
+         (bytes [config.gateway])
+         (bytes [config.netmask])
+         (bytes [config.mac])
+         (bytes [config.ip]))
+
+    (fn u2-reset ()
+      (byte! (ref [U2-MODE]) 0x80)
+      (byte! (ref [U2-MODE]) 0x03)
+      (u2-addr! 0x0001)
+      (u2-write-buf (ref u2-ipconfig) 18)
+      (u2-addr! 0x0016) (u2-write 0)) ; disable interrupts
+
+    (fn u2-udp-server-start (port)
+      (u2-addr! 0x001a)
+      (u2-write 0x03) ; allocate all 8kb rx buffer to socket 0
+      (u2-write 0x03) ; same, but tx
+      (u2-addr! 0x0400)
+      (u2-write 0x42) ; UDP, filter by MAC
+      (u2-addr! 0x0404) ; set port
+      (u2-write-word port)
+      (u2-addr! 0x0401)
+      (u2-write 0x01)  ; open socket
+      (u2-addr! 0x0403)
+      (printnum (u2-read)) (out ": Opened socket"))
+
+    (fn u2-data-ready ()
+      (u2-addr! 0x0426)
+      (u2-read-word))
+
+    (define u2-buf-mask 0x1fff)
+    (global long u2-udp-recv-ip 0)
+    (global word u2-udp-recv-port 0)
+    (global word u2-udp-recv-size 0)
+    (global word u2-udp-recv-rxrd 0)
+    (fn u2-rx-complete ()
+      (u2-addr! 0x0428)
+      (u2-write-word (+ u2-udp-recv-rxrd 8 u2-udp-recv-size))
+      (u2-addr! 0x0401)
+      (u2-write 0x40)) ; RECV command
+
+    (fn u2-rxtx-ptr (rd base) (+ (& rd u2-buf-mask) base))
+    (fn u2-rx-begin ()
+      (if (u2-data-ready)
+          (do (u2-addr! 0x0428)
+              (set! u2-udp-recv-rxrd (u2-read-word))
+              (let (rxrd (u2-rxtx-ptr u2-udp-recv-rxrd 0x6000))
+                (u2-addr! rxrd)
+                (u2-read-buf (ref u2-udp-recv-ip) 8)
+                ; convert from network order
+                (set! u2-udp-recv-port (byteswap u2-udp-recv-port))
+                (set! u2-udp-recv-size (byteswap u2-udp-recv-size))
+                u2-udp-recv-size))
+        0))
+
+    (fn u2-set-tx-dest ((long ip) port)
+      (u2-addr! 0x040c)
+      (u2-write-word (byteswap (loword ip))) ; ip is always network order
+      (u2-write-word (byteswap (hiword ip)))
+      (u2-write-word port))
+
+    (global word u2-udp-send-size 0)
+    (fn u2-tx-begin (size)
+      (set! u2-udp-send-size size)
+      (let (freesize 0) (while (< freesize size)
+        (u2-addr! 0x0420) (set! freesize (u2-read-word))))
+      (u2-addr! 0x0424)
+      (let (txwr (u2-rxtx-ptr (u2-read-word) 0x4000))
+        (u2-addr! txwr)))
+
+    (fn u2-tx-complete ()
+      (u2-addr! 0x0424)
+      (let (txwr (u2-read-word))
+        (u2-addr! 0x0424)
+        (u2-write-word (+ txwr u2-udp-send-size))
+        (u2-addr! 0x0401)
+        (u2-write 0x20)))  ; SEND command
+  ))

ssc/init.fnl

@@ -0,0 +1,552 @@
+; ssc: the sufficiently simple compiler
+
+; The goal of ssc is to allow simple prefix expressions to be compiled into 65816 code that
+; would run at least as fast or faster than the equivalent threaded Forth code. Complex
+; optimizations are a non-goal; if you want to tune the generated code, go ahead and write
+; the assembly directly.
+
+; * Expressions have 3 data types: word (2 bytes), long (4 bytes), void (0 bytes).
+; * Expressions return their results in different places depending on type - word values are stored in the A register,
+;   long values are stored in the direct page at LONG_LO / LONG_HI.
+; * Data and return addresses are mixed on one stack, unlike Forth.
+; * Function calls take a fixed number of arguments, and return 0 or 1 results. The compiler enforces arity checking.
+; * To call a function taking arguments [arg1 arg2 arg3], all 3 arguments should be pushed to the stack before calling.
+;   When the function takes control, the stack should look like this:
+;     arg1 arg2 arg3 return-address
+; * The caller is responsible for removing all arguments from the stack once the function returns.
+; * The caller is responsible for preserving the A, X and Y registers, if this is desirable.
+; * If the function returns a value, it is stored in the A/LONG register, like any expression.
+; * If a function returns no result, it is not obliged to preserve the A/LONG register.
+; * Multitasking is achieved by overlapping the D and S registers on the same 256-byte page of memory.
+;   Yielding to a new task involves saving the S register, setting the D register to the new task's page,
+;   then setting the S register to the saved value in the old task.
+; * Useful task-local "registers" are kept at the beginning of the page, and the stack grows down from the end of the page.
+;   * DP register list:
+;     * LONG (32-bit "register")
+;     * Last suspended value of S
+;     * Mailbox
+;     * Pointer to next task
+
+; Compiler notes:
+; Expressions are of the form [:function arg1 arg2 arg3]
+; args are either strings (symbols) or numbers
+
+(local Object (require :core.object))
+(local lume (require :lib.lume))
+(local Ssc (Object:extend))
+(local Prg (require :asm.asm))
+(local util (require :lib.util))
+(local {: loword : hiword : pairoff : countiter : condlist : prototype} util)
+
+(fn Ssc.new [self ?opts]
+  (local opts (or ?opts {}))
+  (set self.prg (Prg.new (or opts.prg (?. opts.parent :prg)) :65816))
+  (set self.forms (prototype (or opts.forms (?. opts.parent :forms) self.__index.forms)))
+  (set self.functions (prototype (or (?. opts.parent :functions) {})))
+  (set self.locals [])
+  (set self.addr-to-callsite {})
+  (set self.modules (prototype (or (?. opts.parent :modules) {})))
+  (set self.globals (prototype (or (?. opts.parent :globals) {})))
+  (set self.constants (prototype (or (?. opts.parent :constants) {:true 0xffff true 0xffff :false 0 false 0})))
+  (set self.macros (prototype (or opts.macros  (?. opts.parent :macros) self.__index.macros)))
+  (set self.macrobarriers (prototype (or (?. opts.parent :macrobarriers) {:fn true :far-fn true :do true})))
+  (set self.setters (prototype (or (?. opts.parent :setters) {})))
+  (set self.dp-vars (or (?. opts.parent :dp-vars) 0))
+  (set self.gensym-count (or (?. opts.parent :gensym-count) 0))
+  (set self.LONG_LO (or (?. opts.parent :LONG_LO) (self:alloc-dp-var)))
+  (set self.LONG_HI (or (?. opts.parent :LONG_HI) (self:alloc-dp-var)))
+  (set self.ADDR_LO (or (?. opts.parent :ADDR_LO) (self:alloc-dp-var)))
+  (set self.ADDR_HI (or (?. opts.parent :ADDR_HI) (self:alloc-dp-var))))
+
+(fn Ssc.alloc-dp-var [self]
+  (let [addr (.. :d self.dp-vars)]
+    (set self.dp-vars (+ self.dp-vars 2))
+    addr))
+
+(fn Ssc.gensym [self ?prefix]
+  (let [sym (.. "<gensym " self.gensym-count (if ?prefix (.. " " ?prefix ">") ">"))]
+    (set self.gensym-count (+ self.gensym-count 1))
+    sym))
+
+(fn Ssc.push [self name expr ?etype]
+  (let [opgen (if (= ?etype :register) {:lo #[:flatten]}
+                (self:expr-opgen expr ?etype))
+        etype (if (= ?etype :register) :word
+                   ?etype ?etype
+                   opgen.hi :long
+                :word)
+        c-setup (when opgen.setup (opgen.setup))
+        c-hi (when opgen.hi [(opgen.hi :lda) [:pha]])
+        loc {: name :type (if c-hi :word :placeholder)}
+        _ (table.insert self.locals loc) ; if we push a high word onto the stack it shifts stack offsets
+        c-lo [(opgen.lo :lda) [:pha]]]
+    (set loc.type etype)
+    (lume.concat [:block c-setup] c-hi c-lo)))
+
+(fn Ssc.remove-local [self ?name]
+  (let [loc (. self.locals (length self.locals))]
+    (when (not= loc.name ?name) (error (.. "Internal stack error: expected " (or ?name "temporary") ", got " (or loc.name "temporary"))))
+    (tset self.locals (length self.locals) nil)
+    loc))
+
+(fn Ssc.drop [self ?name]
+  (match (. (self:remove-local ?name) :type)
+    :word [:ply]
+    :long [:block [:ply] [:ply]]))
+
+(fn Ssc.pop [self ?name]
+  (let [{:type etype} (self:remove-local ?name)]
+    (values (match etype
+              :word [:pla]
+              :long [:block [:pla] [:sta self.LONG_LO] [:pla] [:sta self.LONG_HI]])
+            etype)))
+
+(fn Ssc.was-dropped [self localcount]
+  (set self.locals (lume.slice self.locals 1 (- (length self.locals) localcount))))
+
+(fn Ssc.define-fn [self name locals f]
+  (assert (not (self:defining?)) "Can't nest function definitions")
+  (set self.defining-fn name)
+  (set self.locals (when locals (lume.clone locals)))
+  (set self.callsites {})
+  (let [result (f)]
+    (set self.defining-fn nil)
+    (set self.callsites {})
+    (assert (or (and (= locals nil) (= self.locals nil))
+                (= (length self.locals) (length locals)))
+        (.. "Left locals on stack?? Expected " (fv locals) " got " (fv self.locals)))
+    (set self.locals [])
+    result))
+
+(fn Ssc.defining? [self] (not= self.defining-fn nil))
+
+; operations that work on the accumulator, like adc or sbc
+; optimization strategy: keep the current result in the accumulator, work from the stack or immediate values
+; 1. take "right" arguments and push them (unless already on stack, immediate, or absolute)
+; 2. load left into accumulator
+; 3. apply until done
+(fn Ssc.accumulation-op [self op first ...]
+  (var etype (self:type-expr first))
+  (for [i 1 (select :# ...)] (when (= (self:type-expr (select i ...)) :long) (set etype :long)))
+  (let [args (icollect [_ val (ipairs [...])] (self:push-opgen val))
+        setup (icollect [_ {: setup} (ipairs args)] (when setup (setup)))
+        acc (: self (.. :expr- etype) first)
+        operations (icollect [i addr (ipairs args)] (op etype addr i))
+        cleanup (icollect [_ {: cleanup} (ipairs args)] (when cleanup (cleanup)))]
+    (values (lume.concat [:block] setup [acc] operations cleanup) etype)))
+
+(fn Ssc.simple-accumulator [self op etype {: lo : hi} ?defaulthi]
+  (match etype
+    :word (lo op)
+    :long [:block [:lda self.LONG_LO] (lo op) [:sta self.LONG_LO]
+                  [:lda self.LONG_HI] (if hi (hi op) [op (or ?defaulthi 0)]) [:sta self.LONG_HI]]))
+
+; comparisons assume left-hand side was in accumulator and cmp (right-hand side) was just executed.
+; For lobranch, the branch should execute if the comparison is FALSE; the label passed is for the false branch.
+; For hibranch, the branch should not execute if the low word still needs to be compared; otherwise, $1 is the true branch,
+; and $2 is the false branch.
+(set Ssc.comparisons
+  {:<    {:hibranch #[:block [:bcc $1] [:bne $2]] :lobranch #[:bcs $1] :opposite :>=}
+   :>    {:swap :< :opposite :<=}
+   :>=   {:hibranch #[:block [:bcc $2] [:bne $1]] :lobranch #[:bcc $1] :opposite :<}
+   :<=   {:swap :>= :opposite :>}
+   :=    {:hibranch #[:bne $2] :lobranch #[:bne $1] :opposite :not=}
+   :not= {:hibranch #[:bne $1] :lobranch #[:beq $1] :opposite :=}
+ })
+
+(fn Ssc.rewrite-condition [self cond] ; rewrite comparisons down to primitives - <, >=, =, not=, or, and. "or" and "and" can nest.
+  (match cond
+    (where [op] (?. self.comparisons op :hibranch)) ; already a primitive op
+      cond
+    (where [op lhs rhs] (?. self.comparisons op :swap))
+      [(. self.comparisons op :swap) rhs lhs]
+    [:not [:not expr]]
+      (self:rewrite-condition expr)
+    (where [:not [op lhs rhs]] (?. self.comparisons op :opposite))
+      (self:rewrite-condition [(. self.comparisons op :opposite) lhs rhs])
+    (where [:not [op & tests]] (or (= op :or) (= op :and))) ; !(x||y) => (!x)&&(!y)
+      (lume.concat [(if (= op :or) :and :or)] (icollect [_ test (ipairs tests)] (self:rewrite-condition [:not test])))
+    [:not expr]
+      (self:rewrite-condition [:not (self:rewrite-condition expr)])
+    (where [op & tests] (or (= op :or) (= op :and)))
+      (lume.concat [op] (icollect [_ test (ipairs tests)] (self:rewrite-condition test)))
+    _ [:not= cond 0]))
+
+(fn Ssc.gen-condition [self cond truelabel falselabel ?depth ?branch-when-true]
+  (let [depth (or ?depth 0)
+        cond (self:rewrite-condition cond)
+        [op & args] cond
+        cmp (. self.comparisons op)]
+    (if cmp
+        (let [[lhs rhs] args
+              ropgen (self:push-opgen rhs)
+              pre (when ropgen.setup (ropgen.setup))
+              lopgen (self:expr-opgen lhs)
+              left (when lopgen.setup (lopgen.setup))
+              truebranch (.. :-if-true-cleanup- depth)
+              falsebranch (.. :-if-false-cleanup- depth)
+              hibranch (when lopgen.hi
+                         [(lopgen.hi :lda) (ropgen.hi :cmp) (cmp.hibranch truebranch falsebranch)])
+              lobranch [(lopgen.lo :lda) (ropgen.lo :cmp) (cmp.lobranch falsebranch)]
+              cleanup (if ropgen.cleanup (ropgen.cleanup) [:flatten])
+              post (if cleanup [truebranch cleanup [:brl truelabel] falsebranch cleanup [:brl falselabel]]
+                       ?branch-when-true [[:bra truelabel]])]
+          (lume.concat [:block] [pre] [left] hibranch lobranch post))
+
+        (or (= op :or) (= op :and))
+        (lume.concat [:block]
+                     (icollect [itest test (ipairs args)]
+                       (let [lastclause (= itest (length args))
+                             nextlabel (.. :-next- op :-clause- itest :- depth)
+                             whentrue (if (= op :or) truelabel (if lastclause truelabel nextlabel))
+                             whenfalse (if (= op :or) (if lastclause falselabel nextlabel) falselabel)]
+                         [:block (self:gen-condition test whentrue whenfalse (+ depth 1) (and (= op :or) (not lastclause))) nextlabel])))
+      (error (.. "Internal error: can't handle conditional " op)))))
+
+(fn Ssc.cmp-to-bool [self op ...] (self:expr-poly [:if [op ...] true false]))
+
+(fn Ssc.compile-function-generic [self name args body post-body returnaddr-type call-instruction]
+  (let [arglocals (self:parse-parameters args)]
+    (self:define-fn name (lume.concat arglocals [{:type returnaddr-type :returnaddr true}])
+      #(let [(c-function etype) (self:expr-poly body)]
+         (self.org:append name c-function (table.unpack post-body))
+         {:arity (length args) :args arglocals :org self.org :type etype : name : call-instruction}))))
+
+(fn Ssc.compile-function [self name args ...] (self:compile-function-generic name args [:do ...] [[:rts]] :word :jsr))
+(fn Ssc.compile-far-function [self name args ...] (self:compile-function-generic name args [:do [:asm [:phb] [:phk] [:plb]] ...] [[:plb] [:rtl]] :long :jsl))
+
+(fn Ssc.asm-localify [self block]
+  (icollect [_ inst (ipairs block)]
+    (match inst
+      [op [:ref sym] & rest] [op sym (table.unpack rest)]
+      (where [op loc ?off] (and (= (type loc) :string) (self:local-offset loc)))
+        [op (+ (self:local-offset loc) (or ?off 0)) :s]
+      (where [op [loc ?off] :y]  (and (= (type loc) :string) (self:local-offset loc)))
+        [op [(+ (self:local-offset loc) (or ?off 0)) :s] :y]
+      [:block] (self:asm-localify inst)
+      _        inst)))
+
+(fn string? [v] (= (type v) :string))
+(fn xxxx-at [v] ; matches byte-at, word-at, long-at
+  (when (string? v)
+    (let [(i-at i-done) (v:find :-at)]
+      (when (and i-at (= i-done (length v))) (v:sub 1 (- i-at 1))))))
+
+(fn Ssc.compile-read-at [self ref etype]   ; opgen catches the trivial cases; we have to compile ref to get a pointer
+  (let [opgen (self:expr-opgen ref)
+        pre (when opgen.setup (opgen.setup))
+        load (if opgen.hi [:lda [[self.ADDR_LO]] :y] [:lda [self.ADDR_LO] :y])
+        load (if (= etype :byte) [:block [:rep 0x30] load [:sep 0x30] [:and 0xff]] load)]
+    (values (condlist :block pre (opgen.lo :lda) [:sta self.ADDR_LO]
+                      (when opgen.hi [:block (opgen.hi :lda) [:sta self.ADDR_HI]])
+                      [:ldy 0] load
+                      (when (= etype :long) [:block [:sta self.LONG_LO] [:ldy 2] load [:sta self.LONG_HI]]))
+            (if (= etype :byte) :word etype))))
+
+(set Ssc.forms
+  {:asm (fn [self ...] (if (self:defining?) (self:asm-localify [:block ...]) (self.org:append (table.unpack (self:asm-localify [...])))))
+   :asm-long (fn [self ...] (values (self:asm-localify [:block ...]) :long))
+   :org (lambda [self org] (set self.org (self.prg:org org)))
+   :start-symbol (lambda [self symbol] (set self.prg.start-symbol symbol))
+   :form (lambda [self name func] (tset self.forms name func))
+   :define (lambda [self name val] (tset self.constants name val))
+   :macro (lambda [self name func] (tset self.macros name func))
+   :macrobarrier (lambda [self formname] (tset self.macrobarriers formname true))
+   :setter (lambda [self name arg ...]
+     (assert (= (length arg) 1))
+     (tset self.setters name (self:compile-function (.. :-set- name) arg ...)))
+   :require (lambda [self name ...]
+              (when (= (. self.modules name) nil)
+                (let [mod (util.reload name)
+                      func (if (= (type mod) :function) mod mod.module)]
+                  (tset self.modules name mod)
+                  (func self ...))))
+   :global (lambda [self etype name ?const]
+             (tset self.globals name {:type etype : name})
+             (self.org:append [:hot-preserve name
+               (match etype
+                 :word [:dw ?const]
+                 :long [:dl ?const]
+                 _ (error (.. "Unrecognized type " (fv etype))))]))
+   :buffer (lambda [self name bytes-or-size]
+             (self.org:append [:hot-preserve name [:bytes (match (type bytes-or-size)
+                                                   :string bytes-or-size
+                                                   :number (string.rep "\x00" bytes-or-size))]]))
+   :do (fn [self ...]
+         (var etype-body :void)
+         (local c-body (lume.concat [:block] (icollect [i (countiter (select :# ...))]
+                                               (let [(expr etype) (self:expr-poly (select i ...))]
+                                                 (set etype-body etype)
+                                                 expr))))
+         (values c-body etype-body))
+   :let (fn [self bindings ...]
+          (let [compiled-bindings     (icollect [_ symbol expr (pairoff bindings)] (self:push symbol expr))
+                (compiled-body etype) (self:expr-poly [:do ...])
+                compiled-cleanup      (icollect [i-half (countiter (/ (length bindings) 2))]
+                                        (self:drop (. bindings (- (length bindings) (* i-half 2) -1))))]
+            (values (lume.concat [:block] compiled-bindings [compiled-body] compiled-cleanup) etype)))
+   :fn (lambda [self name args ...] (tset self.functions name (self:compile-function name args ...)))
+   :far-fn (lambda [self name args ...] (tset self.functions name (self:compile-far-function name args ...)))
+   :predef-fn (lambda [self name args etype ?far]
+                (tset self.functions name {:arity (length args) :args (self:parse-parameters args) :org self.org :type etype : name :call-instruction (if (= ?far :far) :jsl :jsr)}))
+   :if (lambda [self test iftrue ?else ...]
+         (let [(c-true truetype) (self:expr-poly iftrue)
+               iffalse (if (> (select :# ...) 0) [:if ?else ...] ?else)
+               (c-false falsetype) (when (not= iffalse nil) (self:expr-poly iffalse))
+               etype (if (not= truetype falsetype) :void truetype)
+               block [:block (self:gen-condition test :-if-true- :-if-false-) :-if-true- c-true]
+               cl-false (if (not= iffalse nil) [[:bra :-if-done-] :-if-false- c-false :-if-done-]
+                                               [:-if-false-])]
+           (values (lume.concat block cl-false) etype)))
+   :while (lambda [self test ...]
+            (let [block [:block :-loop-top- (self:gen-condition test :-enter-loop- :-exit-loop-) :-enter-loop-]
+                  c-body (self:expr-poly [:do ...])]
+              (values (lume.concat block [c-body [:brl :-loop-top-] :-exit-loop-]) :void)))
+   :forever (lambda [self ...] [:block :-loop-top- (self:expr-poly [:do ...]) [:brl :-loop-top-]])
+   :+ (lambda [self first ...]
+        (self:accumulation-op
+          (fn [etype opgen]
+            (if (and (= etype :word) opgen.const (>= opgen.const -2) (<= opgen.const 2))
+                (match opgen.const  1 [:inc]  2 [:block [:inc] [:inc]]
+                                   -1 [:dec] -2 [:block [:dec] [:dec]])
+              [:block [:clc] (self:simple-accumulator :adc etype opgen)]))
+          first ...))
+   :- (lambda [self first ...]
+        (if (= (select :# ...) 0)
+            (match (self:type-expr first) :word [:block (self:expr-word first) [:eor 0xffff] [:inc]] ; negate with two's complement
+                                          :long (self:expr-poly [:- 0 first])) ; just subtract from 0
+          (self:accumulation-op
+            (fn [etype opgen]
+              (if (and (= etype :word) (>= opgen.const -2) (<= opgen.const 2))
+                  (match opgen.const -1 [:inc] -2 [:block [:inc] [:inc]]
+                                      1 [:dec]  2 [:block [:dec] [:dec]])
+                [:block [:sec] (self:simple-accumulator :sbc etype opgen)]))
+            first ...)))
+    :| (lambda [self first ...] (self:accumulation-op #(self:simple-accumulator :ora $...) first ...))
+    :& (lambda [self first ...] (self:accumulation-op #(self:simple-accumulator :and $...) first ...))
+    :^ (lambda [self first ...] (self:accumulation-op #(self:simple-accumulator :eor $...) first ...))
+    := (lambda [self lhs rhs] (self:cmp-to-bool := lhs rhs))
+    :not= (lambda [self lhs rhs] (self:cmp-to-bool :not= lhs rhs))
+    :< (lambda [self lhs rhs] (self:cmp-to-bool :< lhs rhs))
+    :> (lambda [self lhs rhs] (self:cmp-to-bool :> lhs rhs))
+    :>= (lambda [self lhs rhs] (self:cmp-to-bool :>= lhs rhs))
+    :<= (lambda [self lhs rhs] (self:cmp-to-bool :<= lhs rhs))
+    :not (lambda [self bool] (self:cmp-to-bool :not bool))
+    :or (lambda [self ...] (self:cmp-to-bool :or ...))
+    :and (lambda [self ...] (self:cmp-to-bool :and ...))
+    :loword (lambda [self long]
+              (let [{: lo : setup} (self:expr-opgen long :long)]
+                (lume.concat [:block] [(when setup (setup))] [(lo :lda)])))
+    :hiword (lambda [self long]
+              (let [{: hi : setup} (self:expr-opgen long :long)]
+                (lume.concat [:block] [(when setup (setup))] [(hi :lda)])))
+    :ref (lambda [self label] [:lda #(loword ($1:lookup-addr label))])
+    :far-ref (lambda [self label] (values [:block [:lda #(loword ($1:lookup-addr label))] [:sta self.LONG_LO]
+                                                  [:lda #(hiword ($1:lookup-addr label))] [:sta self.LONG_HI]] :long))
+    :byteswap (lambda [self word] [:block (self:expr-word word) [:xba]])
+    :long (lambda [self value] (values [:block (self:expr-word value) [:sta self.LONG_LO] [:lda 0] [:sta self.LONG_HI]] :long))
+    :byte-at (lambda [self ref] (self:compile-read-at ref :byte))
+    :word-at (lambda [self ref] (self:compile-read-at ref :word))
+    :long-at (lambda [self ref] (self:compile-read-at ref :long))
+    :set! (lambda [self lhs value]
+            (if (and (= (type lhs) :string) (. self.setters lhs))
+                (self:compile-function-call (. self.setters lhs) [value])
+
+                (self:opgen-lhs lhs)
+                (let [{:lo val-lo :hi val-hi : setup} (assert (self:expr-opgen value) (.. (fv value) " did not produce a value"))
+                      c-setup (when setup (setup))
+                      {: lo : hi} (self:opgen-lhs lhs)
+                      c-lo [:flatten (val-lo :lda) (lo :sta)]
+                      c-hi (when hi [:flatten (if val-hi (val-hi :lda) [:lda 0]) (hi :sta)])
+                      block [:block]]
+                  (lume.push block c-setup c-lo c-hi)
+                  (values block :void))
+
+                (and (= (type lhs) :table) (xxxx-at (. lhs 1)))
+                (let [ropgen (self:push-opgen value)
+                      pre1 (when ropgen.setup (ropgen.setup))
+                      lopgen (self:expr-opgen (. lhs 2))
+                      pre2 (when lopgen.setup (lopgen.setup))
+                      etype (xxxx-at (. lhs 1))
+                      store (if lopgen.hi [:sta [[self.ADDR_LO]] :y] [:sta [self.ADDR_LO] :y])
+                      store (if (= etype :byte) [:block [:rep 0x30] store [:sep 0x30]] store)]
+                  (values (condlist :block pre1 pre2 (lopgen.lo :lda) [:sta self.ADDR_LO]
+                                    (when lopgen.hi [:block (lopgen.hi :lda) [:sta self.ADDR_HI]])
+                                    (ropgen.lo :lda) [:ldy 0] store
+                                    (when (= etype :long) [:block (if ropgen.hi (ropgen.hi :lda) [:lda 0]) [:ldy 2] store])
+                                    (when ropgen.cleanup (ropgen.cleanup)))
+                          :void))
+              (error (.. (fv lhs) " not valid as a target of set!"))))
+  })
+(set Ssc.macros
+  {:getter (lambda [self name ...] (let [getter-name (.. "<get " name ">")]
+                                     [:do [:fn getter-name [] ...]
+                                          [:define name [getter-name]]]))
+   :when (lambda [self test ...] [:if test [:do ...]])
+   :byte! (lambda [self ref value] [:set! [:byte-at ref] value])
+   :word! (lambda [self ref value] [:set! [:word-at ref] value])
+   :long! (lambda [self ref value] [:set! [:long-at ref] value])
+   :data (lambda [self bytes]
+     (print "data" bytes (self:defining?))
+     (if (self:defining?) (let [name (self:gensym)] (self:expr-poly [:buffer name bytes]) name)
+       bytes))
+   :pstr (lambda [self str] [:data (.. (string.char (length str)) str)]) ; pascal-style
+   :cstr (lambda [self str] [:data (.. str "\x00")]) ; c-style
+  })
+
+(fn Ssc.local-offset [self name-or-index]
+  (var offset nil)
+  (var stacklen 0)
+  (when self.locals
+    (for [i 1 (length self.locals)]
+      (let [loc (. self.locals i)
+            size (match loc.type :placeholder 0 :word 2 :long 4 _ (error (.. "how big is this local??" (fv loc))))]
+        (set stacklen (+ stacklen size))
+        (when (or (= i name-or-index) (= loc.name name-or-index))
+          (set offset stacklen)))))
+  (when offset (+ (- stacklen offset) 1)))
+
+(fn Ssc.local-type [self name-or-index]
+  (var etype nil)
+  (for [i 1 (length self.locals)]
+    (when (or (= i name-or-index) (= (. self.locals i :name) name-or-index))
+      (set etype (. self.locals i :type))))
+  etype)
+
+(fn Ssc.type-expr [self expr] (let [(_ etype) (self:expr-poly expr)] etype))
+
+; opgen - a small structure that allows for reading a value with many different addressing modes
+; :lo and :hi keys are functions that, when called with an opcode, returns that opcode with the appropriate argument to work on
+; either the low or high word. If :hi does not exist in the structure, then the value represented by the opgen is only word-sized.
+; :setup and :cleanup keys are used by push-opgen to handle generation of the necessary stack manipulation instructions.
+; opgen-const makes the constant available in the :const key so it can be checked and potentially optimized further (+1 -> inc)
+(fn Ssc.opgen-const [self const]
+  {:lo #[$1 (bit.band const 0xffff)] :hi (let [hi (bit.rshift (bit.band const 0xffff0000) 16)] (if (or (= hi 0) (= hi 0xffff)) nil #[$1 hi])) : const})
+
+(fn Ssc.opgen-local [self loc]
+  {:lo #[$1 (self:local-offset loc) :s] :hi (when (= (self:local-type loc) :long) #[$1 (+ (self:local-offset loc) 2) :s])})
+
+(fn Ssc.opgen-symbol [self name etype]
+  (if (= etype :byte) {:lo #[:block [:sep 0x30] [$1 name] [:rep 0x30] (when (= $1 :lda) [:and 0xff])]}
+    {:lo #[$1 name] :hi (when (= etype :long) #[$1 {:abs #(+ ($1:lookup-addr name) 2)}])}))
+
+(fn Ssc.opgen-global [self name] (self:opgen-symbol name (. self.globals name :type)))
+
+(fn Ssc.opgen-ref-loc [self name etype]
+  (when (= (self:local-type name) :word) ; long pointer deref is not possible directly from the stack; have to eval and move to LONG register
+    {:lo #[:block [:ldy 0] [$1 [(self:local-offset name) :s] :y]]
+     :hi (when (= etype :long) #[:block [:ldy 2] [$1 [(self:local-offset name) :s] :y]])}))
+
+(fn Ssc.opgen-lhs [self expr]
+  (match [(type expr) expr]
+    [:string _] (if (self:local-offset expr) (self:opgen-local expr)
+                    (. self.globals expr)    (self:opgen-global expr))
+    (where [_ [type-at [:ref name]]] (string? name) (xxxx-at type-at)) (self:opgen-symbol name (xxxx-at type-at))
+    (where [_ [type-at name]] (string? name) (xxxx-at type-at) (self:local-offset name)) (self:opgen-ref-loc name (xxxx-at type-at))))
+
+(fn Ssc.opgen [self expr]
+  (if (= (type expr) :number) (self:opgen-const expr)
+    (self:opgen-lhs expr)))
+
+(fn Ssc.push-opgen [self expr]
+  (or (self:opgen expr)
+      (let [c (self:push nil expr)
+            iloc (length self.locals)]
+        (lume.merge (self:opgen-local iloc) {:setup #c :cleanup #(self:drop)}))))
+
+(fn Ssc.expr-opgen [self expr ?expected-etype]
+  (var opgen (self:opgen expr))
+  (when (not opgen)
+    (let [(c-expr etype) (self:expr-poly expr)]
+      (set opgen (match etype
+                   :word {:setup #c-expr :lo #[:flatten]}
+                   :long {:setup #c-expr :lo #[$1 self.LONG_LO] :hi #[$1 self.LONG_HI]}))))
+  (when (and (= ?expected-etype :long) (= opgen.hi nil)) (set opgen.hi #[$1 0]))
+  (when (and ?expected-etype (= opgen nil)) (error (.. "Expected " ?expected-etype ", got void")))
+  (when (and (= ?expected-etype :word) opgen.hi) (error (.. "Expected word, got long")))
+  opgen)
+
+(fn Ssc.parse-parameters [self params]
+  (icollect [_ param (ipairs params)] (match param
+                                          [:long pname] {:name pname :type :long}
+                                          pname         {:name pname :type :word})))
+
+(fn Ssc.push-arguments [self paramdefs args]
+  (icollect [iarg arg (ipairs args)]
+    (let [atype (. paramdefs iarg :type)
+          c-push (self:push nil arg atype)]
+      c-push)))
+
+(fn Ssc.compile-function-call [self f args]
+  (let [pre (self:push-arguments f.args args)
+        locals (lume.clone self.locals)
+        callid (or (. self.callsites f.name) 0)
+        _ (tset self.callsites f.name (+ callid 1))
+        funcname self.defining-fn
+        callsite-sym (.. "<callsite " funcname " " f.name ":" callid ">")
+        capture-addr (fn [addr] (tset self.addr-to-callsite (- addr 1) {: callsite-sym : locals : funcname :calling f.name}))
+        post (icollect [_ (countiter (length args))] (self:drop))]
+    (values (lume.concat [:block] pre [[f.call-instruction f.name] callsite-sym [:export callsite-sym] [:meta capture-addr]] post) f.type)))
+
+(fn Ssc.enter-expr [self expr]
+  (let [m (getmetatable expr)]
+    (when (and m m.filename) (set self.expr-metadata m))))
+
+(fn Ssc.expr-expand [self expr]
+  (let [mt (getmetatable expr)
+        expanded (match expr
+                   (where c (. self.constants c)) (self:expr-expand (. self.constants c))
+                   (where [m & args] (. self.macros m)) (self:expr-expand ((. self.macros m) self (table.unpack args)))
+                   (where [f & args] (not (. self.macrobarriers f))) (lume.concat [f] (icollect [_ arg (ipairs args)] (self:expr-expand arg)))
+                   _ expr)
+        _ (when (= (type expanded) :table) (setmetatable expanded mt))]
+    expanded))
+
+(fn Ssc.expr-poly [self expr]
+  (self:enter-expr expr)
+  (let [meta (or self.expr-metadata {:filename "<unknown>" :line "??"})
+        expr (self:expr-expand expr)
+        (success c-expr etype)
+        (pcall #(match expr
+                  (where lit (?. (self:opgen lit) :hi)) (let [{: lo : hi} (self:opgen lit)]
+                    (values [:block (lo :lda) [:sta self.LONG_LO] (hi :lda) [:sta self.LONG_HI]] :long))
+                  (where lit (?. (self:opgen lit) :lo)) (let [{: lo} (self:opgen lit)] (values (lo :lda) :word))
+                  (where [func & args] (= (?. self.functions func :arity) (length args)))
+                    (self:compile-function-call (. self.functions func) args)
+                  (where [form & args] (. self.forms form))
+                    (let [f (. self.forms form)
+                          (cexpr etype) (f self (table.unpack args))]
+                      (values cexpr (or etype :word)))
+                  nil (values [:block] :void)
+                  _ (error (.. "Unrecognized expression"))))]
+    (if success (do (when (and c-expr (= (getmetatable c-expr) nil)) (setmetatable c-expr meta))
+                    (values c-expr etype))
+      (let [{: filename : line} meta] (error (.. filename "@" line ": " c-expr "\n" (fv expr)))))))
+
+(fn Ssc.expr-word [self expr]
+  (let [(c etype) (self:expr-poly expr)]
+    (when (not= etype :word) (error (.. "Unexpected long or void in " (fv expr) " - please wrap in explicit truncation form")))
+    c))
+
+(fn Ssc.expr-long [self expr]
+  (let [(c etype) (self:expr-poly expr)]
+    (match etype
+      :long c
+      :word [:block c [:sta self.LONG_LO] [:lda 0] [:sta self.LONG_HI]]
+      _ (error (.. "Unexpected type " (fv etype) " in " (fv expr) " - wanted long or word")))))
+
+(fn Ssc.compile [self ...]
+  (for [i 1 (select :# ...)]
+    (self:expr-poly (select i ...)))
+  self)
+
+(fn Ssc.assemble [self]
+  (self.prg:assemble)
+  (set self.prg.source self)
+  self.prg)
+
+(fn Ssc.read-hotswap [self machine prg-new]
+  (local {: hotswap-stacks} (require :ssc.hotswap))
+  (hotswap-stacks machine self prg-new.source))
+
+Ssc

ssc/macros.fnl

@@ -0,0 +1,31 @@
+; Sufficiently Simple Syntax macro
+; This is basically just a quote that converts fennel syntax to Lua tables.
+; Turns symbols into strings and lists into table literals. Table literals can be used to escape into regular fennel.
+; Examples:
+;    (let (x 1 y 2) (+ "x" :y))
+; => [:let [:x 1 :y 2] [:+ :x :y]]
+;    (form mymacro [(fn [ssc] (ssc:compile-expr [:+ 1 2]))])
+; => [:form :mymacro (fn [ssc] (ssc:compile-expr [:+ 1 2]))]
+
+(fn attach-metadata [form result]
+  (if (list? form)
+      (let [{: filename : line : bytestart : byteend} form]
+        `(setmetatable ,result ,{: filename : line : bytestart : byteend}))
+    result))
+
+(fn form-to-fnl [form]
+  (attach-metadata form
+    (if (sym? form)      (tostring form)
+        (sequence? form) (. form 1) ; escape
+        (list? form)     (icollect [_ inner-form (ipairs form)] (form-to-fnl inner-form))
+      form)))
+
+(fn sss [...]
+  (let [result `(values)]
+    (for [i 1 (select :# ...)]
+      (table.insert result (form-to-fnl (select i ...))))
+    result))
+
+(fn compile [ssc ...] `(: ,ssc :compile ,(sss ...)))
+
+{: sss : form-to-fnl : compile}

ssc/notes.txt

@@ -0,0 +1,6 @@
+- Could custom forms compile to opgens?? What would this look like?
+  * see far-ref - it's really a constant, there's no reason to stuff the result into the temporary register just to push it onto the stack
+  * if you call expr-poly / expr-word / expr-long, then put it into the register
+  * but if you call expr-opgen, just return it! (opgen.setup) returns the appropriate code if needed
+  * toolbox calls could actually benefit from this! function calls, not so much
+  * currently expr-opgen is assumed to not have a cleanup step - this could complicate things

ssc/stdlib.fnl

@@ -0,0 +1,17 @@
+(import-macros {:sss ! : compile} :ssc.macros)
+
+#(compile $1
+  (fn memcpy ((long src) (long dst) count)
+    (let (bank (| (hiword dst) (byteswap (hiword src))))
+      (asm (lda bank)
+           (sta [{:abs #(+ ($1:lookup-addr :inst) 1)}])
+           (lda src) (tax)
+           (lda dst) (tay)
+           (lda count)
+           (dec)
+           (phb)
+         inst
+           (mvn 0 0)
+           (plb))))
+ )
+

ssc/task.fnl

@@ -0,0 +1,58 @@
+(import-macros {:sss ! : compile} :ssc.macros)
+(local {: addr-parser} (require :asm.65816))
+
+#(compile $1
+  [(do (set $1.TASK-NEXT ($1:alloc-dp-var))
+       (set $1.TASK-STACK ($1:alloc-dp-var))
+       (set $1.TASK-MAILBOX ($1:alloc-dp-var))
+       nil)]
+  (global word old-dp 0)
+  (global word old-sp 0)
+
+  (form save-dp-sp    [#[:block [:tdc] [:sta :old-dp] [:tsc] [:sta :old-sp]]])
+  (form restore-dp-sp [#[:block [:lda :old-dp] [:tcd] [:lda :old-sp] [:tcs]]])
+  (form save-6502-stack    [#[:block [:tsc] [:tay] [:and 0xff] [:ora 0x100] [:tax] [:eor 0xffff] [:clc] [:adc 0x200] [:phb] [:mvn 0 0] [:plb]]])
+  (form restore-6502-stack [#[:block [:tsc] [:tax] [:and 0xff] [:ora 0x100] [:tay] [:eor 0xffff] [:clc] [:adc 0x200] [:phb] [:mvn 0 0] [:plb]]])
+; 0x1ef = 0x1ef-0x1ff = 0x0f -> 0x7f
+  (define task-size 0x100)
+  (global word first-task)
+  (global word last-task)
+
+  (form set-task-base [(fn [ssc task-base]
+    [:block [:lda task-base] [:tcd]
+            [:sta ssc.TASK-NEXT] [:sta :first-task] [:sta :last-task]
+            [:tsc] [:and 0xff] [:ora task-base] [:tcs]])])
+
+  (fn yield ()
+    (asm (tsc) (sta [$1.TASK-STACK]) ;  
+         debug-stub on-hotswap (export debug-stub) (export on-hotswap) ; todo: cleanup mame hotswap logic
+         (lda [$1.TASK-NEXT]) (tcd)
+         (lda [$1.TASK-STACK]) (tcs)))
+
+  (fn yield-forever () (while true (yield)))
+
+  (fn reset-task (task f)
+    ; setup stack
+    (word! (long (+ task 0xfe)) (- (ref yield-forever) 1)) ; allow tasks to return; rts adds one to the value on the stack for the next pc
+    (word! (long (+ task 0xfc)) (- f 1))                   ; yield will return to this address
+    (word! (long (+ task [(addr-parser $1.TASK-STACK)]))   (+ task 0xfb)) ; stack pointer is the next available location
+    (word! (long (+ task [(addr-parser $1.TASK-MAILBOX)])) 0)             ; clear mailbox
+  )
+
+  (fn new-task (f)
+    (let (next-task (+ last-task task-size))
+      (reset-task next-task f)
+      (word! (long (+ next-task [(addr-parser $1.TASK-NEXT)])) first-task) ; the last task yields to the first task, round-robin
+      (word! (long (+ last-task [(addr-parser $1.TASK-NEXT)])) next-task)  ; the previously-last task now yields to us
+      (set! last-task next-task)
+      next-task))
+
+  (form current-task [#[:tdc]])
+
+  (fn task-send (task msg)
+    (word! (long (+ task [(addr-parser $1.TASK-MAILBOX)])) msg))
+
+  (form task-peek [#[:lda $1.TASK-MAILBOX]])
+
+  (fn task-recv ()
+    (asm (ldx [$1.TASK-MAILBOX]) (lda 0) (sta [$1.TASK-MAILBOX]) (txa))))

vendor/lite/.gitrepo

@@ -4,9 +4,9 @@
 ; git-subrepo command. See https://github.com/git-commands/git-subrepo#readme
 ;
 [subrepo]
-	remote = https://github.com/jeremypenner/lite.git
+	remote = git@github.com:jeremypenner/lite
 	branch = master
-	commit = 2783adc10c2f42beefdbc7f19cec8971e4e9bb80
-	parent = dab1881d90ab1514301a081a9dbc265325672b20
+	commit = 384d54f9e343af74993766e6cedcf1498c5fdba6
+	parent = 3a4d6ff460eb0bc473ad779bc05a7d0153dc1ca7
 	method = merge
-	cmdver = 0.4.2
+	cmdver = 0.4.3

wrap.fnl

@@ -10,6 +10,8 @@
 (local translate (require :core.doc.translate))
 (local files (require :game.files))
 
+(setmetatable _G nil)
+
 (command.add nil {
   "honeylisp:open-project" (fn []
     (core.command_view:enter "Open Project"
@@ -23,6 +25,14 @@
             (table.insert files item.filename)))
         (common.fuzzy_match files text))))})
 
+(fn selected-symbol []
+  (local ldoc core.active_view.doc)
+  (var (aline acol bline bcol) (ldoc:get_selection))
+  (when (and (= aline bline) (= acol bcol))
+    (set (aline acol) (translate.start_of_word ldoc aline acol))
+    (set (bline bcol) (translate.end_of_word ldoc bline bcol)))
+  (ldoc:get_text aline acol bline bcol))
+
 (command.add #(link.machine:connected?) {
   "honeylisp:upload" (fn []
     (local p (util.reload "game"))
@@ -48,18 +58,20 @@
     (editor.inline-eval vm-eval))
 })
 
+(command.add #(and (link.machine:connected?) link.machine.set-bp) {
+  "honeylisp:set-breakpoint" (fn []
+    (local word (selected-symbol))
+    (local p (require "game"))
+    (local addr (p:lookup-addr word))
+    (if addr (do (link.machine:set-bp addr)
+                 (core.log (.. "Set breakpoint at " addr)))
+      (core.log (.. "Unknown address for " word))))
+})
+
 (command.add (fn [] true) {
   "honeylisp:rebuild" #(util.reload "game")
 })
 
-(fn selected-symbol []
-  (local ldoc core.active_view.doc)
-  (var (aline acol bline bcol) (ldoc:get_selection))
-  (when (and (= aline bline) (= acol bcol))
-    (set (aline acol) (translate.start_of_word ldoc aline acol))
-    (set (bline bcol) (translate.end_of_word ldoc bline bcol)))
-  (ldoc:get_text aline acol bline bcol))
-
 (command.add "core.docview" {
   "fennel:eval" #(editor.inline-eval #(fv (fennel.eval $1 {:env _G :compiler-env _G}) {}))
   "lume:hotswap" (fn []
@@ -83,6 +95,7 @@
   "alt+v" "honeylisp:vm-eval"
   "alt+r" "lume:hotswap"
   "alt+a" "honeylisp:address"
+  "alt+b" "honeylisp:set-breakpoint"
   "alt+l" "honeylisp:reload"
 })