Title screen, screen editor, and new slim loader

asm/asm.fnl

@@ -120,9 +120,13 @@
   (fn parse-dats [block dats]
     (each [_ dat (ipairs dats)]
       (if (= (type dat) "string")
-        (do (tset block.symbols dat (+ (length block.pdats) 1))
-            (when (= (dat:sub 1 2) "G-")
-              (tset block.globals dat true)))
+          (do (tset block.symbols dat (+ (length block.pdats) 1))
+              (when (= (dat:sub 1 2) "G-")
+                (tset block.globals dat true)))
+
+          (not= (type dat) :table)
+          (error (.. "Invalid operation " dat))
+          
         (let [opcode (. dat 1)
               parser (. dat-parser opcode)
               pdat

asm/prodos.fnl

@@ -6,7 +6,9 @@
 (local lume (require :lib.lume))
 
 (local prodos-mli :0xbf00)
+(fn Prodos.str [str] [:block [:db (length str)] [:bytes str]])
 (fn Prodos.install-words [vm]
+  (fn vm.pstr [self str] (self:anon (Prodos.str str)))
   (fn prodos-call [cmd param-addr crash-on-fail]
     [:block
       [:jsr prodos-mli]

asm/vm.fnl

@@ -53,8 +53,9 @@
         (error (.. "VM can't parse " (fv bytecode)))))
     block))
 
-(fn mk-vm [prg options]
-  (local code1 (prg:org 0x4000))
+(fn mk-vm [prg ?options]
+  (local options (or ?options {}))
+  (local code1 (prg:org (or options.org 0x4000)))
   (install-vm-parser prg)
   (local vm {
     :IP   :0x60

editor/brushedit.fnl

@@ -0,0 +1,17 @@
+(local TileView (require :editor.tileedit))
+(local tiledraw (require :editor.tiledraw))
+(local tiles (require :game.tiles))
+(local style (require :core.style))
+
+(local BrushEditView (TileView:extend))
+
+(fn BrushEditView.spritegen [self] tiledraw.char-to-sprite)
+(fn BrushEditView.tilesize [self] (values 8 8))
+(fn BrushEditView.tilekeys [self] [:gfx :mask])
+(fn BrushEditView.map-bitxy [self x y] (values y x))
+(fn BrushEditView.filename [self] "editor/brushes.json")
+(fn BrushEditView.get_name [self] "Brush Editor")
+(fn BrushEditView.draw-tile-flags [self x y])
+
+BrushEditView
+

editor/brushes.json

@@ -0,0 +1 @@
+[{"mask":"FFFFFFFFFFFFFFFF","gfx":"D5D5D5D5D5D5D5D5","flags":[]},{"mask":"00008F8F8F000000","gfx":"00000A0A0A000000","flags":[]},{"mask":"00008F8F8F000000","gfx":"00008A8A8A000000","flags":[]},{"mask":"0000BCBCBC000000","gfx":"0000141414000000","flags":[]},{"mask":"0000BCBCBC000000","gfx":"0000949494000000","flags":[]},{"mask":"0000000C0C000000","gfx":"0000000C0C000000","flags":[]},{"mask":"00000C1E1E0C0000","flags":[],"gfx":"0000000000000000"},{"mask":"3E7F7F7F7F7F7F3E","gfx":"3E7F7F7F7F7F7F3E","flags":[]}]

editor/gfxedit.fnl

@@ -16,6 +16,7 @@
   (attach-imstate self))
 (fn GraphicsEditView.spritegen [self] tiledraw.tile-to-sprite)
 (fn GraphicsEditView.tilesize [self] (values 16 16))
+(fn GraphicsEditView.tilebytelen [self] (let [(w h) (self:tilesize)] (/ (* w h) 8)))
 (fn GraphicsEditView.filename [self] tiles.fn-tiles)
 (fn GraphicsEditView.reload [self]
   (self.tilecache:load (tiles.loadgfx (self:filename))))

editor/init.fnl

@@ -2,6 +2,7 @@
 (local util (require :lib.util))
 (local TileView (require :editor.tileedit))
 (local MapEditView (require :editor.mapedit))
+(local ScreenEditView (require :editor.screenedit))
 (local PortraitView (require :editor.portraitedit))
 (local {: cmd-predicate} (util.require :editor.imstate))
 (local core (require :core))
@@ -10,26 +11,30 @@
 (local common (require :core.common))
 
 (let [commands {}]
-  (each [_ name (ipairs [:tile :portrait :font])]
+  (each [_ name (ipairs [:tile :portrait :font :brush])]
     (local cls (require (.. "editor." name "edit")))
     (tset commands (.. "honeylisp:" name "-editor") (fn []
       (local node (core.root_view:get_active_node))
       (node:add_view (cls)))))
   (command.add nil commands))
 
-(command.add nil {
-  "honeylisp:map-editor" (fn []
-    (core.command_view:enter "Open Map"
-      (fn [text item]
-        (local node (core.root_view:get_active_node))
-        (node:add_view (MapEditView (or (and item item.text) text))))
-      (fn [text]
-        (local files [])
-        (each [_ item (pairs core.project_files)]
-          (when (and (= item.type :file) (item.filename:find "^game/map%d+%.json"))
-            (table.insert files item.filename)))
-        (common.fuzzy_match files text))))
-})
+(local fileeditors
+  {:map    {:view MapEditView    :filefilter "^game/map%d+%.json"}
+   :screen {:view ScreenEditView :filefilter "^game/.*%.screen"}})
+
+(each [type {: view : filefilter} (pairs fileeditors)]
+  (command.add nil
+    {(.. "honeylisp:" type "-editor") (fn []
+      (core.command_view:enter (.. "Open " type)
+        (fn [text item]
+          (local node (core.root_view:get_active_node))
+          (node:add_view (view (or (and item item.text) text))))
+        (fn [text]
+          (local files [])
+          (each [_ item (pairs core.project_files)]
+            (when (and (= item.type :file) (item.filename:find filefilter))
+              (table.insert files item.filename)))
+          (common.fuzzy_match files text))))}))
 
 (command.add (cmd-predicate :editor.gfxedit) {
   "graphics-editor:save"          (fn [] (core.active_view:save) (core.log "Saved"))
@@ -41,7 +46,7 @@
   "tileedit:copy"
   #(system.set_clipboard (: (core.active_view:tile) :tohex))
   "tileedit:paste"
-  #(when (= (length (system.get_clipboard)) 64)
+  #(when (= (length (system.get_clipboard)) (* (core.active_view:tilebytelen) 2))
     (core.active_view:update-tile (: (system.get_clipboard) :fromhex)))
 })
 (keymap.add {

editor/screenedit.fnl

@@ -0,0 +1,96 @@
+(local GraphicsEditView (require :editor.gfxedit))
+(local util (require :lib.util))
+(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 ScreenEditView (GraphicsEditView:extend))
+(local screen-scale 4)
+(local screenw 280)
+(local screenh 192)
+
+(fn ScreenEditView.new [self filename]
+  (ScreenEditView.super.new self)
+  (set self.screenfilename filename)
+  (set self.scanlines [])
+  (self:reload))
+
+(fn gfxshift [byte offset]
+  (local pixels (bit.band (string.byte byte) 0x7f))
+  (local color (bit.band (string.byte byte) 0x80))
+  (bit.bor color
+    (if (> offset 0) (bit.band (bit.lshift pixels offset) 0x7f)
+      (bit.rshift pixels (- offset)))))
+
+(fn brush-mask-at [brush xoffset y]
+  (values (gfxshift (brush.gfx:sub y y) xoffset) (gfxshift (brush.mask:sub y y) xoffset)))
+
+(fn paint-byte [src brush mask]
+  (if (not= (bit.band mask 0x7f) 0)
+      (-> src
+        (bit.band (bit.bxor 0xff mask))
+        (bit.bor brush))
+    src))
+
+(fn paint-byte-at [screen brush y xbyte xoffset yoffset]
+  (if (and (>= xbyte 0) (< xbyte 40) (>= y 0) (< y screenh))
+      (let [ibyte (+ (screen-y-to-offset y) xbyte)
+            srcbyte (screen:sub (+ ibyte 1) (+ ibyte 1))
+            painted (paint-byte (string.byte srcbyte) (brush-mask-at brush xoffset yoffset))]
+        (util.splice screen ibyte (string.char painted)))
+    screen))
+
+(fn paint [screen brush x y]
+  (var result screen)
+  (for [row y (+ y 7)]
+    (local xbyte (math.floor (/ x 7)))
+    (local xoffset-left (% x 7))
+    (local xoffset-right (- xoffset-left 7))
+    (local yoffset (+ (- row y) 1))
+    (set result (paint-byte-at result brush row xbyte xoffset-left yoffset))
+    (set result (paint-byte-at result brush row (+ xbyte 1) xoffset-right yoffset)))
+  result)
+
+(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)
+  (var screen self.screen)
+  (when (and self.itile (mouse-inside x y w h))
+    (local mx (math.floor (/ (- (love.mouse.getX) x) screen-scale)))
+    (local my (math.floor (/ (- (love.mouse.getY) y) screen-scale)))
+    (set screen (paint screen (. self.tilecache.tiles self.itile) (bit.band (- mx 3) 0xfffe) (- my 4)))
+    (when (active? self :screen) (set self.screen screen)))
+
+  (for [scany 0 (- screenh 1)]
+    (local scanline (or (. self.scanlines scany) {}))
+    (local ibyte (screen-y-to-offset scany))
+    (local linehash (screen:sub (+ ibyte 1) (+ ibyte 40)))
+    (when (not= scanline.linehash linehash)
+      (set scanline.linehash linehash)
+      (set scanline.sprite (scanline-to-sprite screen scany))
+      (tset self.scanlines scany scanline))
+    (love.graphics.draw scanline.sprite x (+ y (* scany screen-scale)) 0 screen-scale screen-scale)))
+
+(fn ScreenEditView.reload [self]
+  (ScreenEditView.super.reload self)
+  (local (loaded screen) (pcall #(util.readjson self.screenfilename)))
+  (set self.screen
+    (if (not loaded) (string.rep "\0" 0x2000)
+      (screen:fromhex))))
+
+(fn ScreenEditView.save [self]
+  (util.writejson self.screenfilename (self.screen:tohex)))
+
+(fn ScreenEditView.draw [self]
+  (self:draw_background style.background)
+  (love.graphics.setColor 1 1 1 1)
+  (self:draw-screen-editor (+ self.position.x 10) (+ self.position.y 10))
+  (self:draw-tile-selector (+ self.position.x 10) (+ self.position.y 20 (* screenh screen-scale)) (- self.size.x 20)))
+
+(fn ScreenEditView.filename [self] "editor/brushes.json")
+(fn ScreenEditView.spritegen [self] char-to-sprite)
+(fn ScreenEditView.tilesize [self] (values 8 8))
+(fn ScreenEditView.get_name [self] (.. "Screen: " self.screenfilename))
+
+ScreenEditView

editor/tiledraw.fnl

@@ -70,6 +70,28 @@
 
 (fn tile-to-sprite [tile] (if tile (tilestrip-to-sprite [tile]) (make-canvas 14 16 #nil)))
 
+(fn screen-y-to-offset [y]
+  (var offset (* (% y 8) 0x400))
+  (local ybox (math.floor (/ y 8)))
+  (local ysection (match (math.floor (/ ybox 8))
+                    0 0x0000
+                    1 0x0028
+                    2 0x0050))
+  (+ offset ysection (* (% ybox 8) 0x80)))
+
+(fn draw-scanline [screen y ydest]
+  (local ibyte (+ 1 (screen-y-to-offset y)))
+  (var state nil) (var prevpal nil)
+  (for [x 0 39]
+    (set (state prevpal) (draw-byte screen (+ ibyte x) (* x 7) ydest state prevpal))))
+
+(fn scanline-to-sprite [screen y]
+  (make-canvas 280 1 (fn [canvas] (draw-scanline screen y 0))))
+
+(fn screen-to-sprite [screen]
+  (make-canvas 280 192 (fn [canvas]
+    (for [y 0 191] (draw-scanline screen y y)))))
+
 (fn portrait-to-sprite [gfx]
   (local top (tilestrip-to-sprite [(gfx:sub 1 32) (gfx:sub 65 96)]))
   (local bottom (tilestrip-to-sprite [(gfx:sub 33 64) (gfx:sub 97 128)]))
@@ -79,8 +101,9 @@
 
 (fn char-to-sprite [gfx]
   (make-canvas 7 8 (fn [canvas]
-    (for [y 0 7]
-      (draw-byte gfx (+ y 1) 0 y)))))
+    (when gfx
+      (for [y 0 7]
+        (draw-byte gfx (+ y 1) 0 y))))))
 
 (fn TileCache [tiles ?spritegen]
   {: tiles
@@ -108,5 +131,6 @@
        (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 : pal-from-bit : pal-from-byte : TileCache}
+{: 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}
 

editor/tileedit.fnl

@@ -87,9 +87,6 @@
 
 (fn TileView.save [self] (tiles.savegfx (self:filename) self.tilecache.tiles))
 
-(fn TileView.draw-neut-tile-selector [self x y]
-  (self:draw-tile-selector x (- self.size.x 20) :neut))
-
 (fn TileView.draw [self]
   (self:draw_background style.background)
   (local (x y) (values (+ self.position.x 10) (+ self.position.y 10)))

game/disk.fnl

@@ -1,4 +1,5 @@
 (local asm (require :asm.asm))
+(local VM (require :asm.vm))
 (local Prodos (require :asm.prodos))
 (local util (require :lib.util))
 (local {: lo : hi} util)
@@ -30,8 +31,12 @@
     [:bne :ld-src]
   :done])
 
-(fn prg-loader [org game]
+(fn create-sys-loader [disk filename game]
   (local blocks [])
+  (local prg (asm.new game))
+  (local org (prg:org 0x2000))
+  (org:append :loader-main)
+  (set prg.start-symbol :loader-main)
   (each [_ block (pairs game.org-to-block)]
     (table.insert blocks block))
   (table.sort blocks #(< $1.addr $2.addr))
@@ -39,19 +44,48 @@
     (org:append (org-loader block)))
   (org:append [:jmp game.start-symbol])
   (each [_ block (ipairs blocks)]
-    (org:append (.. :loader- block.addr) [:bytes block.bytes])))
+    (org:append (.. :loader- block.addr) [:bytes block.bytes]))
+  (prg:assemble)
+  (disk:add-file (.. filename ".SYSTEM") Prodos.file-type.SYS 0x2000 org.block.bytes))
 
-(local game (util.reload :game))
-(local prg (asm.new game))
-(local org (prg:org 0x2000))
+(fn create-loader [disk game]
+  (local boot (asm.new game))
+  (set boot.start-symbol :boot)
+  (local vm (VM.new boot {:org 0xc00}))
+  (disk.install-words vm)
+  (vm:def :hires
+    [:sta :0xc050]
+    [:sta :0xc057]
+    [:sta :0xc052]
+    [:sta :0xc054])
+  (vm:word :loadfile ; length addr filename --
+    0xbb00 :open :read :drop :close)
 
-(org:append :loader-main)
-(set prg.start-symbol :loader-main)
-(prg-loader org game)
-(prg:assemble)
+  (disk:add-file "TITLE.SCREEN" Prodos.file-type.BIN 0x2000 (: (util.readjson "game/title.screen") :fromhex))
+  (vm.code:append
+    :boot
+    [:jsr :reset]
+    [:jsr :interpret]
+    [:vm :hires
+      0x2000 0x2000 (vm:pstr "TITLE.SCREEN") :loadfile])
+  (local files [])
+  (each [_ block (pairs game.org-to-block)]
+    (local filename (.. "STUFF." (length files)))
+    (table.insert files filename)
+    (disk:add-file filename Prodos.file-type.BIN block.addr block.bytes)
+    (vm.code:append [:vm (length block.bytes) block.addr :lit (.. :filename (length files)) :loadfile]))
+  (vm.code:append
+    [:vm :native]
+    [:jmp game.start-symbol])
+  (each [i filename (ipairs files)]
+    (vm.code:append (.. :filename i) (disk.str filename)))
+  (boot:assemble)
+  boot)
 
 (local disk (Prodos "ProDOS_Blank.dsk"))
-(disk:add-file "NEUT.SYSTEM" Prodos.file-type.SYS 0x2000 org.block.bytes)
+(local game (util.reload :game))
+(local loader (create-loader disk game))
+(create-sys-loader disk :NEUT loader)
 (disk:update-volume-header {:name "NEUT.TOWER"})
 (disk:write "NeutTower.dsk")
 

game/tiles.fnl

@@ -6,7 +6,7 @@
 (each [iflag flag (ipairs flags)]
   (tset flag-to-bit flag (bit.lshift 1 (- iflag 1))))
 
-(local encoded-tile-fields [:gfx :neut])
+(local encoded-tile-fields [:gfx :neut :mask])
 (fn convert [tile field method]
   (local oldval (. tile field))
   (when oldval