First cut at disk image generation; generated disk will not currently boot

asm/asm.fnl

@@ -7,10 +7,10 @@
 (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 :brk 0x00 :rti 0x40
+       :txa 0x8a :txs 0x9a :tax 0xaa :tsx 0xba :dex 0xca :nop 0xea :rti 0x40 :rts 0x60}]
-       :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}]

asm/prodos.fnl

@@ -0,0 +1,336 @@
+(local Object (require :core.object))
+(local Prodos (Object:extend))
+(local {: bytes-to-uint8 : bytes-to-uint16 : bytes-to-uint24
+        : int8-to-bytes  : int16-to-bytes  : int24-to-bytes
+        : splice : lo : hi} (require :lib.util))
+
+(local prodos-mli :0xbf00)
+(fn Prodos.install-words [vm]
+  (fn prodos-call [cmd param-addr crash-on-fail]
+    [:block
+      [:jsr prodos-mli]
+      [:db cmd]
+      [:ref param-addr]
+      (when crash-on-fail
+        [:block
+          [:beq :success]
+          [:brk 0]
+          :success])])
+  (vm.code:append :currently-open-file [:db 0])
+  (vm:def :open ; filename buffer --
+    [:block
+      [:lda vm.ST1 :x]  [:sta :open-param-filename]
+      [:lda vm.ST1H :x] [:sta :open-param-filename-hi]
+      [:lda vm.TOP :x]  [:sta :open-param-buffer]
+      [:lda vm.TOPH :x] [:sta :open-param-buffer-hi]
+      (prodos-call 0xc8 :open-params true)
+      [:lda :open-param-refnum]
+      [:sta :currently-open-file]
+      (vm:drop) (vm:drop)])
+  (vm.code:append
+    :open-params            [:db 3]
+    :open-param-filename    [:db 0]
+    :open-param-filename-hi [:db 0]
+    :open-param-buffer      [:db 0]
+    :open-param-buffer-hi   [:db 0]
+    :open-param-refnum      [:db 0])
+
+  (vm:def
+    [:block
+    :flush [:export :flush] ; --
+      [:lda 0xcd]
+      [:bne :prodos-flush-close]
+    :close [:export :close] ; --
+      [:lda 0xcc]
+    :prodos-flush-close
+      [:sta :fc-cmd]
+      [:lda :currently-open-file]
+      [:sta :fc-param-refnum]
+      [:jsr prodos-mli]
+    :fc-cmd [:db 0] [:ref :fc-params]
+      [:beq :success]
+      [:brk 0]
+    :success])
+  (vm.code:append
+    :fc-params       [:db 1]
+    :fc-param-refnum [:db 0])
+
+  (vm:def
+    [:block
+    :write [:export :write] ; count buffer -- count
+      [:lda 0xcb]
+      [:bne :prodos-read-write]
+    :read [:export :read] ; count buffer -- count
+      [:lda 0xca]
+    :prodos-read-write
+      [:sta :rw-cmd]
+      [:lda :currently-open-file]
+      [:sta :rw-param-refnum]
+      [:lda vm.TOP :x]  [:sta :rw-param-buffer]
+      [:lda vm.TOPH :x] [:sta :rw-param-buffer-hi]
+      [:lda vm.ST1 :x]  [:sta :rw-param-count]
+      [:lda vm.ST1H :x] [:sta :rw-param-count-hi]
+      [:jsr prodos-mli]
+    :rw-cmd [:db 0] [:ref :rw-params]
+      [:beq :success]
+      [:cmp 0x4c]
+      [:beq :success]
+      [:brk 0]
+    :success
+      [:lda :rw-param-count-out]    [:sta vm.ST1 :x]
+      [:lda :rw-param-count-out-hi] [:sta vm.ST1H :x]
+      (vm:drop)])
+  (vm.code:append
+    :rw-params             [:db 4]
+    :rw-param-refnum       [:db 0]
+    :rw-param-buffer       [:db 0]
+    :rw-param-buffer-hi    [:db 0]
+    :rw-param-count        [:db 0]
+    :rw-param-count-hi     [:db 0]
+    :rw-param-count-out    [:db 0]
+    :rw-param-count-out-hi [:db 0])
+
+  ; this does not handle files bigger than 64kb; I don't want or need to implement 24-bit numbers
+  (vm:def :seek ; position --
+    [:lda :currently-open-file]
+    [:sta :seek-param-refnum]
+    [:lda vm.TOP :x]  [:sta :seek-param-position]
+    [:lda vm.TOPH :x] [:sta :seek-param-position-hi]
+    (prodos-call 0xce :seek-params true)
+    (vm:drop))
+  (vm.code:append
+    :seek-params            [:db 2]
+    :seek-param-refnum      [:db 0]
+    :seek-param-position    [:db 0]
+    :seek-param-position-hi [:dw 0]))
+
+(fn Prodos.new [self filename]
+  (local f (io.open filename :r))
+  (set self.bytes (f:read "*a"))
+  (f:close)
+  (assert (= (length self.bytes) 143360))
+  (self:parse-structure))
+
+(fn Prodos.write [self filename]
+  (local f (io.open filename :w))
+  (f:write self.bytes)
+  (f:close))
+
+(fn Prodos.sector-offset [self itrack isector]
+  (+ (* itrack 0x1000) (* isector 0x100)))
+(fn Prodos.sector [self itrack isector]
+  (local offset (self:sector-offset itrack isector))
+  (self.bytes:sub (+ offset 1) (+ offset 0x100)))
+
+(fn Prodos.set-sector [self itrack isector bytes]
+  (assert (<= (length bytes) 256))
+  (set self.bytes (splice self.bytes (+ (* itrack 0x1000) (* isector 0x100)) bytes)))
+
+(local prodos-to-dos [0 14 13 12 11 10 9 8 7 6 5 4 3 2 1 15])
+(fn Prodos.block-sectors [self index]
+  (local track (math.floor (/ index 8)))
+  (local iprodos (* (% index 8) 2))
+  (local isector1 (. prodos-to-dos (+ 1 iprodos)))
+  (local isector2 (. prodos-to-dos (+ 2 iprodos)))
+  (values track isector1 isector2))
+
+(fn Prodos.block [self index]
+  (local (track isector1 isector2) (self:block-sectors index))
+  (.. (self:sector track isector1) (self:sector track isector2)))
+
+(fn Prodos.set-block [self index bytes]
+  (local (track isector1 isector2) (self:block-sectors index))
+  (self:set-sector track isector1 (bytes:sub 1 256))
+  (self:set-sector track isector2 (bytes:sub 257 512))
+  (local bitmap (self:parse-bitmap))
+  (when (. bitmap index)
+    (tset bitmap index nil)
+    (self:set-bitmap bitmap)))
+
+(fn Prodos.parse-entry [self bytes]
+  (local type_namelen (bytes-to-uint8 bytes 0))
+  (local entry-type (bit.rshift (bit.band type_namelen 0xf0) 4))
+  (local namelen (bit.band type_namelen 0x0f))
+  (local name (bytes:sub 2 (+ 1 namelen)))
+  (if (= entry-type 0x0f)
+    {: entry-type : name
+     :version (bytes-to-uint8 bytes 0x1c)
+     :min-version (bytes-to-uint8 bytes 0x1d)
+     :access (bytes-to-uint8 bytes 0x1e)
+     :entry-length (bytes-to-uint8 bytes 0x1f)
+     :entries-per-block (bytes-to-uint8 bytes 0x20)
+     :file-count (bytes-to-uint16 bytes 0x21)
+     :bitmap-pointer (bytes-to-uint16 bytes 0x23)
+     :total-blocks (bytes-to-uint16 bytes 0x25)}
+    {: entry-type : name
+     :file-type (bytes-to-uint8 bytes 0x10)
+     :key-pointer (bytes-to-uint16 bytes 0x11)
+     :blocks-used (bytes-to-uint16 bytes 0x13)
+     :eof (bytes-to-uint24 bytes 0x15)
+     :version (bytes-to-uint8 bytes 0x1c)
+     :min-version (bytes-to-uint8 bytes 0x1d)
+     :access (bytes-to-uint8 bytes 0x1e)
+     :aux-type (bytes-to-uint16 bytes 0x1f)
+     :header-pointer (bytes-to-uint16 bytes 0x25)}))
+
+(fn Prodos.parse-directory [self iblock]
+  (local bytes (self:block iblock))
+  (local prev-block (bytes-to-uint16 bytes 0x00))
+  (local next-block (bytes-to-uint16 bytes 0x02))
+  (local entries [])
+  (for [offset 0x04 0x1ff 0x27]
+    (when (>= (length bytes) (+ offset 0x27))
+      (local entry (self:parse-entry (bytes:sub (+ offset 1) (+ offset 0x27))))
+      (set entry.entry-offset offset)
+      (table.insert entries entry)))
+  {: prev-block : next-block : entries})
+
+(set Prodos.storage-type {
+  :deleted 0
+  :seedling 1
+  :sapling 2
+  :tree 3
+  :dir 13
+  :subdir-header 14
+  :volume-header 15
+})
+
+(set Prodos.file-type {
+  :none 0x00
+  :BAD  0x01
+  :TXT  0x04
+  :BIN  0x06
+  :DIR  0x0F
+  :ADB  0x19
+  :AWP  0x1a
+  :ASP  0x1b
+  :PAS  0xef
+  :CMD  0xf0
+  :BAS  0xfc
+  :VAR  0xfd
+  :REL  0xfe
+  :SYS  0xff
+})
+
+(fn Prodos.parse-structure [self]
+  (set self.files {})
+  (set self.next-free nil)
+  (set self.root nil)
+  (var iblock 2)
+  (while (~= iblock 0)
+    (local dir (self:parse-directory iblock))
+    (each [ientry entry (ipairs dir.entries)]
+      (match entry.entry-type
+        self.storage-type.volume-header (set self.root entry)
+        self.storage-type.deleted       (set self.next-free {: entry : iblock : ientry})
+        _                               (tset self.files entry.name {: entry : iblock : ientry})))
+    (set iblock dir.next-block))
+  self)
+
+(fn Prodos.parse-index [self iblock]
+  (local block (self:block iblock))
+  (local index [])
+  (for [i 1 256]
+    (local lo (block:sub i i))
+    (local hi (block:sub (+ i 256) (+ i 256)))
+    (table.insert index (bytes-to-uint16 (.. lo hi)))))
+
+(fn Prodos.set-index [self iblock index]
+  (var block "")
+  (for [i 1 256] (set block (.. block (string.char (lo (or (. index i) 0))))))
+  (for [i 1 256] (set block (.. block (string.char (hi (or (. index i) 0))))))
+  (self:set-block iblock block))
+
+(fn bit-in-bytes [bytes ibit]
+  (local ibyte (math.floor (/ ibit 8)))
+  (local byte (string.byte (bytes:sub (+ ibyte 1) (+ ibyte 1))))
+  (local mask (bit.lshift 1 (% ibit 8)))
+  (values byte mask ibyte))
+
+(fn Prodos.parse-bitmap [self]
+  (local block (self:block self.root.bitmap-pointer))
+  (local bitmap {})
+  (for [ibit 0 280]
+    (local (byte mask) (bit-in-bytes block ibit))
+    (when (~= (bit.band byte mask) 0)
+      (tset bitmap ibit true)))
+  bitmap)
+
+(fn Prodos.set-bitmap [self bitmap]
+  (var block (string.rep "\0" 512))
+  (each [ibit f (pairs bitmap)]
+    (when (= f true)
+      (local (byte mask ibyte) (bit-in-bytes block ibit))
+      (set block (splice block ibyte (string.char (bit.bor byte mask))))))
+  (self:set-block self.root.bitmap-pointer block))
+
+(fn Prodos.find-next-free-block [self]
+  (next (self:parse-bitmap)))
+
+(fn Prodos.add-file-data [self bytes]
+  (assert (< (length bytes) 0xffff))
+  (if (> (length bytes) 512)
+      (let [index []]
+        (for [offset 1 (length bytes) 512]
+          (local iblock (self:add-file-data (bytes:gsub offset (+ offset 511))))
+          (table.insert index iblock))
+        (local iblock-index (self:find-next-free-block))
+        (self:set-index iblock-index index)
+        (values iblock-index self.storage-type.sapling (+ (length index) 1)))
+
+      (let [iblock-index (self:find-next-free-block)]
+        (self:set-block iblock-index bytes)
+        (values iblock-index self.storage-type.seedling 1))))
+
+(fn Prodos.generate-file-entry [self iblock-parent filename type aux bytes]
+  (local (iblock storage-type block-count) (self:add-file-data bytes))
+  (..
+    (int8-to-bytes (bit.bor (bit.lshift storage-type 4) (length filename)))
+    filename
+    (string.rep "\0" (- 15 (length filename)))
+    (int8-to-bytes type)
+    (int16-to-bytes iblock)
+    (int16-to-bytes block-count)
+    (int24-to-bytes (length bytes))
+    "\0\0\0\0" ; created date
+    (int8-to-bytes 36) ; version
+    (int8-to-bytes 0) ; min-version
+    (int8-to-bytes 0x01) ; access (read-only, locked)
+    (int16-to-bytes aux) ; aux-type - generally load address
+    "\0\0\0\0" ; last modified date
+    (int16-to-bytes iblock-parent)))
+
+(fn Prodos.generate-volume-header [self ?overrides]
+  (local overrides (or ?overrides {}))
+  (local name (or overrides.name self.root.name))
+  (..
+    (int8-to-bytes (bit.bor (bit.lshift self.storage-type.volume-header 4) (length name)))
+    name
+    (string.rep "\0" (- 15 (length name)))
+    "\0\0\0\0\0\0\0\0" ; reserved
+    "\0\0\0\0" ; created date
+    (int8-to-bytes 36) ; version
+    (int8-to-bytes 0) ; min-version
+    (int8-to-bytes 0x01) ; access (read-only, locked)
+    (int8-to-bytes 0x27)
+    (int8-to-bytes 0x0d)
+    (int16-to-bytes (or overrides.file-count self.root.file-count))
+    (int16-to-bytes (or overrides.bitmap-pointer self.root.bitmap-pointer))
+    (int16-to-bytes 280)))
+
+(fn Prodos.update-volume-header [self ?overrides]
+  (local block (-> (self:block 2) (splice 4 (self:generate-volume-header ?overrides))))
+  (self:set-block 2 block)
+  (self:parse-structure))
+
+(fn Prodos.add-file [self filename type aux bytes]
+  (assert self.next-free)
+  (local iblock self.next-free.iblock)
+  (var block (self:block iblock))
+  (local file-entry (self:generate-file-entry iblock filename type aux bytes))
+  (print (length file-entry) file-entry)
+  (set block (splice block self.next-free.entry.entry-offset file-entry))
+  (self:set-block iblock block)
+  (self:update-volume-header {:file-count (+ self.root.file-count 1)}))
+
+Prodos

editor/tileedit.fnl

@@ -33,10 +33,7 @@
     (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))))
-    (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) (tiledraw.pal-from-bit bit))

game/bosskey.fnl

@@ -47,17 +47,12 @@
    (cells 16 ["TOTAL" style.inverse] "TOO MANY" ["* MAGIC *" style.flashing] "ALL@ONCE")
    (cells 17) (cells 18) (cells 19) (cells 20)])
 
-(fn splice [bytes offset str]
-  (.. (bytes:sub 1 offset)
-      str
-      (bytes:sub (+ (length str) offset 1))))
-
 (fn bytes-from-lines [lines]
   (var bytes (string.rep (astr " ") 0x400))
   (each [y line (ipairs lines)]
     (local offset (+ (* (math.floor (/ (- y 1) 8)) 0x28)
                      (* (% (- y 1) 8) 0x80)))
-    (set bytes (splice bytes offset line)))
+    (set bytes (util.splice bytes offset line)))
   bytes)
 
 (textorg:append [:bytes (bytes-from-lines (generate-boss-screen-lines))])

game/disk.fnl

@@ -0,0 +1,19 @@
+(local asm (require :asm.asm))
+(local Prodos (require :asm.prodos))
+(local {: basic} (require :asm.tape))
+
+(local prg (basic (asm.new)))
+(local org (prg:org 0x801))
+
+(org:append [:basic
+  [10 :print "\"HELLO FROM A GENERATED DISK IMAGE!\""]
+  [20 :goto :10]])
+
+(prg:assemble)
+
+(local disk (Prodos "ProDOS_2_4_2.dsk"))
+(disk:add-file "STARTUP" Prodos.file-type.BAS 0x801 org.block.bytes)
+(disk:update-volume-header {:name "NEUT.TOWER"})
+(pp disk)
+(disk:write "Test.dsk")
+

lib/util.fnl

@@ -13,6 +13,21 @@
   (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)))
+(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))))
+  (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 splice [bytes offset str]
+  (.. (bytes:sub 1 offset)
+      str
+      (bytes:sub (+ (length str) offset 1))))
 
 (fn reload [modname]
   (tset package.loaded modname nil)
@@ -61,5 +76,8 @@
 
 (fn in-coro [f ...] (-> (coroutine.create f) (coroutine.resume ...)))
 
-{: lo : hi : int8-to-bytes : int16-to-bytes : reload : hotswap : swappable :require swappable-require : readjson : writejson : waitfor : in-coro}
+{: 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
+ : readjson : writejson : waitfor : in-coro}
 

link/serial.fnl

@@ -41,7 +41,7 @@
      (set bytes-to-write (bytes-to-write:sub 11))
      (set addrout (+ addrout 10))))
  :monitor (fn [self] (self:cmd "CALL-151"))
- :stub (fn [self org post-debug-stub]) ; todo
+;  :stub (fn [self org post-debug-stub]) ; todo
 })
 
 (command.add #(not (machine:connected?)) {

todo.txt

@@ -1,3 +1,40 @@
+FLOPPY DISK IDEAS:
+* I am not going to write my own DOS
+* I will use ProDOS - BOOTI-compatible, modern
+* ProDOS 2.4.2 - https://prodos8.com/
+* Generate file(s) to be injected into a blank bootable ProDOS disk image
+
+thinking:
+neut.tower contains all code / data
+loader.system contains a small program that maps offsets of 512-byte blocks to memory addresses
+- is loaded to 0x2000 & will be wiped by gfx? No, PRODOS is loaded at $2000 and moved
+- no, XXX.SYSTEM is loaded to 0x2000 as well
+- Alternately, we could write one program that batch-loads the whole game into $2000 and moves it to where it belongs?
+- How big is the game with all levels? Could we load the whole thing into consecutive memory starting at $4000?
+  - (I don't think this would work on 32kb tape-loaded machines...)
+- With ProDOS I can assume 64kb
+prodos claims:
+$bf00-$ffff - ProDOS
+$9600-$bf00 - BASIC.SYSTEM - don't care?
+$0100-$0800 - "other use or reserved"
+$3A-$3F - used by disk routines, unsafe
+$40-$4F - used by ProDOS but preserved, safe to use
+
+system bitmap: marks pages of memory as "not valid to allocate a file buffer"
+- loader will have to protect memory that it will be moving game code to?
+
+https://prodos8.com/docs/techref/calls-to-the-mli/
+the existence of SET_BUF should mean we can load directly to the memory
+we care about? orr I guess 512 bytes is housekeeping stuff (index block)
+
+16kb version - $0000-$4000 - no we need at least 32kb
+there's basically only 5kb of code space for an hgr game?
+$0000-$03ff 0kb-1kb - zp, stack, input buffer, DOS
+$0400-$07ff 1kb-2kb - text page 1
+$0800-$0bff 2kb-3kb - text page 2
+$0c00-$1fff 3kb-8kb - free space
+$2000-$4000 8kb-16kb - hgr gfx page 1
+
 Game:
 * level loading
 * Title screen