Implement tile editor, reorganize code

asm/asm.fnl

@@ -1,5 +1,5 @@
-(local lume (require "lume"))
+(local lume (require "lib.lume"))
-(local {: int8-to-bytes : int16-to-bytes} (require "util"))
+(local {: int8-to-bytes : int16-to-bytes} (require "lib.util"))
 (local opcodes {})
 
 ; op mode arg

asm/vm.fnl

@@ -1,5 +1,5 @@
-(local lume (require "lume"))
+(local lume (require "lib.lume"))
-(local {: lo : hi} (require "util"))
+(local {: lo : hi} (require "lib.util"))
 
 (fn inc16-stk [l h]
   [:block

editor/init.fnl

@@ -0,0 +1,24 @@
+(require :editor.lite)
+(local TileView (require :editor.tileedit))
+(local core (require :core))
+(local command (require :core.command))
+(local keymap (require :core.keymap))
+
+(command.add nil {
+  "honeylisp:edit-tiles" (fn []
+    (local node (core.root_view:get_active_node))
+    (node:add_view (TileView))) ; allow hot reload
+})
+
+(command.add :editor.tileedit {
+  "tileedit:save"          (fn [] (core.active_view:save) (core.log "Saved tiles"))
+  "tileedit:next-tile"     #(core.active_view:select-rel 1)
+  "tileedit:previous-tile" #(core.active_view:select-rel -1)
+})
+
+(keymap.add {
+  "ctrl+s" "tileedit:save"
+  "left"   "tileedit:previous-tile"
+  "right"  "tileedit:next-tile"
+})
+

editor/lite.lua

@@ -0,0 +1 @@
+../../lite/main.lua

editor/tileedit.fnl

@@ -0,0 +1,117 @@
+(local core (require :core))
+(local command (require :core.command))
+(local style (require :core.style))
+(local View (require :core.view))
+(local tile (require :game.tile))
+(local lume (require :lib.lume))
+
+(local TileView (View:extend))
+
+(local pixel-size 24)
+
+(local xy-to-ibit [])
+(for [x 0 15] (tset xy-to-ibit x []))
+(for [y 0 15]
+  (tset (. xy-to-ibit 0) y (+ (* y 8) 7))
+  (for [ibit 0 6]
+    (tset (. xy-to-ibit (+ ibit 1)) y (+ (* y 8) ibit))))
+(for [y 0 15] (for [x 0 7]
+  (tset (. xy-to-ibit (+ x 8)) y (+ (* (+ y 16) 8) x))))
+(fn map-bitxy [x y]
+  (when (and (>= x 0) (< x 16) (>= y 0) (< y 16))
+    (local ibit (. xy-to-ibit x y))
+    (values (math.floor (/ ibit 8)) (% ibit 8))))
+(fn map-bit [x y]
+  (local bitx (math.floor (/ x (+ 1 pixel-size))))
+  (local bity (math.floor (/ y (+ 1 pixel-size))))
+  (map-bitxy bitx bity))
+
+(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]
+  (..
+    (tile:sub 1 ibyte)
+    (string.char (set-bit tile ibyte ibit is-set))
+    (tile:sub (+ ibyte 2))))
+
+(fn draw-bit-color [bit x y]
+  (local (bgcolor color)
+    (if bit
+      (values [20 207 253] [255 106 60])
+      (values [255 68 253] [20 245 60])))
+  (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 draw-tile [tile x y]
+  (for [bitx 0 15] (for [bity 0 15]
+    (local bit (get-bit tile (map-bitxy bitx bity)))
+    (local (px py) (values (+ x (* bitx (+ pixel-size 1))) (+ y (* bity (+ pixel-size 1)))))
+    (if (or (= bitx 0) (= bitx 15))
+      (draw-bit-color bit px py)
+      (draw-bit bit px py (= (% bitx 2) 1))))))
+
+(fn TileView.new [self]
+  (self.super.new self)
+  (set self.tiles (tile.loadtiles))
+  (set self.itile 1))
+
+(fn TileView.tile [self] (or (. self.tiles self.itile) (string.rep "\0" 32)))
+(fn TileView.update-tile [self newtile] (tset self.tiles self.itile newtile))
+(fn TileView.set-bit [self ibyte ibit bit-set]
+  (set self.ibyte ibyte)
+  (set self.ibit ibit)
+  (set self.bit-set bit-set)
+  (self:update-tile (set-tile-bit (self:tile) ibyte ibit bit-set))
+  true)
+
+(fn TileView.save [self] (tile.savetiles self.tiles))
+(fn TileView.select-rel [self ditile]
+  (local itile (+ self.itile ditile))
+  (when (>= itile 1) (set self.itile itile)))
+
+(fn TileView.draw [self]
+  (self:draw_background style.background)
+  (local (x y) (values (+ self.position.x 10) (+ self.position.y 10)))
+  (local ybelow (draw-tile (self:tile) x y))
+  (local (byte bit) (map-bit (- (love.mouse.getX) x) (- (love.mouse.getY) y)))
+  (when (and byte bit)
+    (renderer.draw_text style.font (: "%d, %d" :format byte bit) x ybelow style.text)))
+
+(fn TileView.selected-bit [self mx my]
+  (local (x y) (values (+ self.position.x 10) (+ self.position.y 10)))
+  (values (map-bit (- mx x) (- my y))))
+
+(fn TileView.on_mouse_pressed [self button mx my clicks]
+  (if (self.super.on_mouse_pressed self button mx my clicks) true
+    (do
+      (local (ibyte ibit) (self:selected-bit mx my))
+      (if (not (and ibyte ibit)) false
+        (self:set-bit ibyte ibit (not (get-bit (self:tile) ibyte ibit)))))))
+
+(fn TileView.on_mouse_moved [self mx my dx dy]
+  (self.super.on_mouse_moved self mx my dx dy)
+  (when (and self.ibyte self.ibit)
+    (local (ibyte ibit) (self:selected-bit mx my))
+    (when (and ibyte ibit (or (not= ibyte self.ibyte) (not= ibit self.ibit)))
+      (self:set-bit ibyte ibit self.bit-set))))
+
+(fn TileView.on_mouse_released [self button x y]
+  (self.super.on_mouse_released self button x y)
+  (set self.ibyte nil)
+  (set self.ibit nil)
+  (set self.bit-set nil))
+
+(fn TileView.get_name [self] "Tile Editor")
+
+TileView

game/init.fnl

@@ -1,7 +1,8 @@
-(local lume (require "lume"))
+(local lume (require "lib.lume"))
-(local asm (require "asm"))
+(local asm (require "asm.asm"))
-(local VM (require "vm"))
+(local VM (require "asm.vm"))
-(local {: lo : hi} (require "util"))
+(local tile (require :game.tile))
+(local {: lo : hi} (require "lib.util"))
 
 (local prg (asm.new))
 ; (prg:debug-to "test.dbg")
@@ -42,11 +43,13 @@
   (vm:for :dup :get :. :inc :inc) :drop)
 
 ; Graphics routines
-(vm:def :mixed-hires
+(vm:def :hires
   [:sta :0xc050]
   [:sta :0xc057]
   [:sta :0xc052])
 
+(vm:def :mixed [:sta :0xc051])
+
 ; starting address:
 ; 0x2000 + (x*2) + (y%4 * 0x100) + ((y/4) * 0x28)
 ; x between 0-19
@@ -68,8 +71,9 @@
   [:sta vm.TOP :x]          ; low byte is set
 )
 
-; note: the graphical tile data must not cross a page boundary!
+; note: the graphical tile data must not cross a page boundary
-; TODO: add support to the assembler for enforcing that
+; (this happens automatically because each tile is 32 bytes and we
+; start them on a page; this lets lookup-tile be fast)
 (fn draw-block []
   [:block
     [:clc]
@@ -141,16 +145,19 @@
   [:tya] [:and 0xe0]
   [:sta vm.TOP :x])
 
-(tiles:append :blanktile [:bytes "\0\0\0\0\0\0\0\0\0\255\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0    \0\0\0\0\0\0"])
+(tile.appendtiles (tile.loadtiles) tiles)
-(tiles:append :testtile [:bytes "12345678901234567890123456789012"])
+; (tiles:append :blanktile [:bytes "\0\0\0\0\0\0\0\0\0\255\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"])
-(tiles:append [:bytes "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz"])
+; (tiles:append :testtile [:bytes "12345678901234567890123456789012"])
-;; 19x11 means full map is 209 bytes
+; (tiles:append :stripetile [:bytes "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz"])
+
+; 19x11 means full map is 209 bytes
 (: (prg:org 0x6800) :append :map [:bytes (string.rep "\0\032\064" 85)])
 (code1:append :main
   [:jsr :reset]
   [:jsr :interpret]
-  [:vm :mixed-hires
+  [:vm :hires; :mixed
     :cleargfx :drawmap
+;    0x0000 :tile>screen 0 :lookup-tile :drawtile
     :quit])
 
 (prg:assemble)

game/tile.fnl

@@ -0,0 +1,19 @@
+(local util (require :lib.util))
+(local lume (require :lib.lume))
+
+(fn loadtiles []
+  (lume.map
+    (util.readjson "game/tiles.json")
+    #($1:fromhex)))
+
+(fn savetiles [tiles]
+  (util.writejson
+    "game/tiles.json"
+    (lume.map tiles #($1:tohex))))
+
+(fn appendtiles [tiles org]
+  (each [_ tile (ipairs tiles)]
+    (org:append [:bytes tile])))
+
+{: loadtiles : savetiles : appendtiles}
+

game/tiles.json

@@ -0,0 +1 @@
+["000000020A0820202A2020080A02000000010141511105045404051151410100","808080C0C0C0E0C0D0C8C04040404080808083858585828A9282820A08081980","007C0C0C0C0C7C007C7E7EAA88888800001F181818181F001F0F979590909000"]

lib/util.fnl

@@ -1,4 +1,5 @@
-(local lume (require "lume"))
+(local lume (require :lib.lume))
+(local json (require :lib.dkjson))
 
 (fn string.fromhex [str]
   (str:gsub ".." (fn [cc] (string.char (tonumber cc 16)))))
@@ -36,5 +37,16 @@
 (fn swappable-require [modname]
   (swappable (require modname)))
 
-{: lo : hi : int8-to-bytes : int16-to-bytes : reload : hotswap : swappable :require swappable-require}
+(fn readjson [filename]
+  (local f (io.open filename :r))
+  (local text (f:read "*a"))
+  (f:close)
+  (json.decode text))
+
+(fn writejson [filename value]
+  (local f (io.open filename :w))
+  (f:write (json.encode value))
+  (f:close))
+
+{: lo : hi : int8-to-bytes : int16-to-bytes : reload : hotswap : swappable :require swappable-require : readjson : writejson}
 

link/machine.fnl

@@ -1,7 +1,7 @@
 (local command (require "core.command"))
-(local {: spawn : kill } (require "spawn"))
+(local {: spawn : kill } (require "lib.spawn"))
 (local socket (require "socket"))
-(local json (require "dkjson"))
+(local json (require "lib.dkjson"))
 
 (local gsplus-path "/home/jeremy/src/gsplus/result/bin/GSplus")
 

lite.lua

@@ -1 +0,0 @@
-../lite/main.lua

main.lua

@@ -3,7 +3,9 @@ fennel = require("lib.fennel")
 table.insert(package.loaders, fennel.make_searcher({correlate=true}))
 fv = require("lib.fennelview")
 pp = function(x) print(fv(x)) end
-lume = require("lume")
+lume = require("lib.lume")
+-- these set global variables and can't be required after requiring core.strict
+imgui = require("imgui")
 luars232 = require("luars232")
 
 _coroutine_resume = coroutine.resume

ops.rkt

@@ -1,192 +0,0 @@
-#lang racket
-; 4 stages:
-; DEFINITION: at this stage, labels must be defined as pointing to zero page memory or not
-; SIZING: given the definitions, how big is each piece?
-; ALLOCATION: knowing how big each piece is now allows us to assign concrete addresses to labels
-; GENERATION: with addresses calculated, we can now generate the correct machine language code
-
-; env: symbol -> def
-; DEFINITION: (label, area, sizer)
-; SIZING: (sizer denv) -> (size, generator)
-; ALLOCATION: (label, area, sizer) -> (label, address, generator)
-; GENERATION: (generator aenv) -> bytes
-
-; two kinds of labels:
-; lexical (local) labels: not exported from the containing block, generally used by relative branches
-; global labels: can be referred to from anywhere
-
-(require racket/generic)
-(define-generics address-def
-  (zeropage? address-def))
-(define-generics op
-  (size op env)
-  (gen-bytes op env addr))
-
-(struct area (addrStart addrEnd) #:transparent
-  #:methods gen:address-def
-  [(define (zeropage? area) (< (area-addrEnd area) #x100))])
-(struct addr (addr) #:transparent
-  #:methods gen:address-def
-  [(define (zeropage? addr) (< (addr-addr addr) #x100))])
-(define zp (area #x00 #xff))
-(define stack (area #x0100 #x01ff))
-(define 300hole (area #x0300 #x03cf))
-(define grpage1 (area #x0400 #x07ff))
-(define grpage2 (area #x0800 #x0bff))
-(define c00hole (area #xc00 #x1fff))
-(define page1 (area #x2000 #x3fff))
-(define page2 (area #x4000 #x5fff))
-(define freespace (area #x6000 #x95ff))      
-
-(struct op-singlebyte (byte) #:transparent
-  #:methods gen:op
-  [(define (size op env) 1)
-   (define (gen-bytes op env addr) (bytes (op-singlebyte-byte op)))])
-
-(define (get-addr env sym-or-addr)
-    (if (addr? sym-or-addr) sym-or-addr
-        (hash-ref env sym-or-addr)))
-
-(define (mode-from-arg env arg)
-  (define (if-zp addr zpmode nonzpmode)
-    (let [(resolved (get-addr env addr))]
-      (list
-        (if (zeropage? resolved) zpmode nonzpmode)
-        resolved)))
-  (match arg
-    [(list imm) #:when (number? imm) (list 'imm imm)]
-    [(list addr 'x) (if-zp addr 'zp-x 'abs-x)]
-    [(list addr 'y) (if-zp addr 'zp-y 'abs-y)]
-    [(list addr) (if-zp addr 'zp 'abs)]
-    [(list 'a) (list 'a #f)]
-    [(list (list addr)) (list 'abs* (get-addr addr))]
-    [(list (list addr) 'y) (if-zp addr 'zp*-y #f)]
-    [(list (list addr 'x)) (if-zp addr 'zp-x* #f)]
-    [else #f]))
-
-(struct op-arg (base modes arg) #:transparent
-  #:methods gen:op
-  [(define (size op env)
-     (match (mode-from-arg env (op-arg-arg op))
-       [(list _ #f) 1]
-       [(list mode _) #:when (string-prefix? (symbol->string mode) "abs") 3]
-       [else 2]))
-   (define (gen-bytes op env addr)
-     (let* [(modes (op-arg-modes op))
-            (mode-val (mode-from-arg env (op-arg-arg op)))
-            (mode (car mode-val))
-            (val (cadr mode-val))
-            (byte (modes (op-arg-base op) mode))]
-        (case (size op env)
-          [(1) (bytes byte)]
-          [(2) (bytes byte (bitwise-and val #xff))]
-          [(3) (bytes byte (bitwise-and val #xff) (bitwise-and (arithmetic-shift val -8) #xff))])))])
-
-(struct op-branch (byte target) #:transparent
-  #:methods gen:op
-  [(define (size op env) 2)
-   (define (gen-bytes op env addr)
-     (let* [(dst-addr (get-addr env (op-branch-target op)))
-            (rel (- (+ addr 2) (addr-addr dst-addr)))]
-        (bytes (op-branch-byte op) (bitwise-and rel #xff))))])
-
-(define-syntax (make-ops stx)
-  (syntax-case stx ()
-    [(_ op-maker ops ...)
-     #`(begin
-         #,@(for/list [(op (syntax->list #'(ops ...)))]
-              #`(op-maker #,@op)))]))
-
-(define-syntax-rule (make-singlebyte-op op byte)
-  (begin
-    (define (op) (op-singlebyte byte))
-    (provide op)))
-
-(make-ops make-singlebyte-op 
-  (php #x08) (plp #x28) (pha #x48) (pla #x68) (dey #x88) (tay #xa8) (iny #xc8) (inx #xe8)
-  (clc #x18) (sec #x38) (cli #x58) (sei #x78) (tya #x98) (clv #xb8) (cld #xd8) (sed #xf8)
-  (txa #x8a) (txs #x9a) (tax #xaa) (tsx #xba) (dex #xca) (nop #xea) (brk #x00) (rti #x40)
-  (rts #x60))
-
-(define-syntax-rule (make-arg-op op base modes)
-  (begin
-    (define (op . arg) (op-arg base modes arg))
-    (provide op)))
-
-(define (indexed-modes modelist)
-  (lambda (base mode)
-    (match (index-of modelist mode)
-      [imode #:when (number? imode) (bitwise-ior base (arithmetic-shift imode 2))]
-      [#f #f])))
-
-(define (without-modes modes . ignored-modes)
-  (lambda (base mode) (if (member mode ignored-modes) #f (modes base mode))))
-(define (only-modes modes . mode-subset)
-  (lambda (base mode) (if (member mode mode-subset) (modes base mode) #f)))
-(define (override-modes lmodes rmodes)
-  (lambda (base mode) (let [(lmode (lmodes base mode))] (if lmode lmode (rmodes base mode)))))
-(define (make-base aaa cc)
-  (bitwise-ior cc (arithmetic-shift aaa 5)))
-(define-syntax (make-cc-ops stx)
-  (syntax-case stx ()
-    [(_ cc modes ops ...)
-     #`(begin
-         #,@(for/list [(op (syntax->list #'(ops ...)))]
-              (syntax-case op ()
-                [(opname base)
-                 #'(make-arg-op opname (make-base base cc) modes)])))]))
-
-(define cc1-modes (indexed-modes '(zp-x* zp imm abs zp*-y zp-x abs-y abs-x)))
-(make-cc-ops 1 cc1-modes 
-  (ora 0) (and 1) (eor 2) (adc 3) (lda 5) (cmp 6) (sbc 7))
-(make-arg-op sta (make-base 4 1) (without-modes cc1-modes 'imm))
-
-(define cc2-modes (indexed-modes '(imm zp a abs _ zp-x _ asb-x)))
-(make-cc-ops 2 (without-modes cc2-modes 'imm)
-  (asl 0) (rol 1) (lsr 2) (ror 3))
-(make-arg-op stx (make-base 4 2) (indexed-modes '(_ zp _ abs _ _ zp-y)))
-(make-arg-op ldx (make-base 5 2) (indexed-modes '(imm zp _ abs _ _ zp-y _ abs-y)))
-(make-cc-ops 2 (without-modes cc2-modes 'imm 'a)
-  (dec 6) (inc 7))
-
-(define cc0-modes (indexed-modes '(imm zp _ abs _ zp-x _ abs-x)))
-(make-arg-op bit (make-base 1 0) (only-modes cc0-modes 'zp 'abs))
-(make-arg-op jmp (make-base 2 0) 
-  (lambda (base mode)
-    (case mode
-      [('abs) #x4c]
-      [('abs*) #x6c]
-      [else #f])))
-(make-arg-op sty (make-base 4 0) (only-modes cc0-modes 'zp 'abs 'zp-x))
-(make-arg-op ldy (make-base 5 0) cc0-modes)
-(make-cc-ops 0 (only-modes cc0-modes 'imm 'zp 'abs)
-  (cpy 6) (cpx 7))
-
-(define-syntax-rule (make-branch-op op byte)
-  (begin
-    (define (op target) (op-branch byte target))
-    (provide op)))
-(make-ops make-branch-op
-  (bpl #x10) (bmi #x30) (bvc #x50) (bvs #x70) (bcc #x90) (bcs #xb0) (bne #xd0) (beq #xf0))
-
-(struct block (oplist area labels exported) #:transparent
-  #:methods gen:op
-  [(define (size block env)
-      (let [(new-env
-              (for/fold [(new-env env)]
-                        [(label (hash-keys (block-labels block)))]
-                (hash-set new-env label (block-area block))))]
-        (for/sum [(op (block-oplist block))] (size op))))
-   (define (gen-bytes block env addr)
-      (let-values 
-        [([end-addr iop-to-addr cop]
-          (for/fold [(curr-addr addr) (iop-to-addr #hash()) (iop 0)]
-                    [(op (block-oplist block))]
-            (let* [(opsize (size op env))
-                   (next-addr (+ addr opsize))]
-              (values next-addr (hash-set iop-to-addr iop curr-addr) (+ iop 1)))))]))])
-        ; draw the rest of the fucking owl
-        
-(define defblock (area ops)
-  (let [(oplist
-          (for/fold [(i 0) (oplist)]))]))

wrap.fnl

@@ -1,9 +1,9 @@
-(require "lite")
+(require "editor")
-(local util (require "util"))
+(local util (require "lib.util"))
-(local lume (require "lume"))
+(local lume (require "lib.lume"))
 (local imgui (require "imgui"))
-(local serial (require "serial"))
+(local serial (require "link.serial"))
-(local gsplus (require "machine"))
+(local gsplus (require "link.machine"))
 (local core (require "core"))
 (local command (require "core.command"))
 (local keymap (require "core.keymap"))
@@ -19,12 +19,12 @@
 })
 (command.add #(machine:connected?) {
   "honeylisp:upload" (fn []
-    (local p (util.reload "neut"))
+    (local p (util.reload "game"))
     (p:upload machine)
     (core.log (string.format "%x" (p:lookup-addr p.start-symbol))))
 })
 (command.add (fn [] true) {
-  "honeylisp:rebuild" #(util.reload "neut")
+  "honeylisp:rebuild" #(util.reload "game")
 })
 
 (fn selected-symbol []
@@ -56,7 +56,7 @@
     (when (not= err nil) (print err) (error err)))
   "honeylisp:address" (fn []
     (local word (selected-symbol))
-    (local p (require "neut"))
+    (local p (require "game"))
     (core.log (string.format "%s %x" word (or (p:lookup-addr word) -1)))
   )
 })