cassette port support

asm/asm.fnl

@@ -158,7 +158,7 @@
   })
 
   (fn process-pdat [pdat process default ...]
-    (pp pdat)
+;     (pp pdat)
     (local processor (. pdat-processor pdat.type process))
     (if processor (processor pdat ...) default))
 
@@ -309,10 +309,10 @@
        (set self.dbgfile nil))
      self)
    :upload
-   (fn [self machine only-self]
+   (fn [self machine]
-     (when (and (not only-self) self.prg-base) (self.prg-base:upload machine))
+     (if machine.upload (machine:upload self)
        (each [org block (pairs self.org-to-block)]
-       (machine:write block.addr block.bytes)))
+         (machine:write block.addr block.bytes))))
   })
 
 {:new program}

asm/tape.fnl

@@ -0,0 +1,56 @@
+(local asm (require :asm.asm))
+(local util (require :lib.util))
+(local lume (require :lib.lume))
+
+(local tokens {})
+    (each [i tok (ipairs [:end :for :next :data :input :del :dim :read :gr :text :pr# :in# :call :plot
+                      :hlin :vlin :hgr2 :hgr :hcolor= :hplot :draw :xdraw :htab :home :rot= :scale=
+                      :shload :trace :notrace :normal :inverse :flash :color= :pop :vtab :himem:
+                      :lomem: :onerr :resume :recall :store :speed= :let :goto :run :if :restore
+                      :& :gosub :return :rem :stop :on :wait :load :save :deffn :poke :print :cont
+                      :list :clear :get :new :tab :to :fn :src :then :at :not :step :+ :- :* "/" ";"
+                      :and :or :> := :< :sgn :int :abs :usr :fre :scrn :pdl :pos :sqr :rnd :log :exp
+                      :cos :sin :tan :atn :peek :len :str$ :val :asc :chr$ :left$ :right$ :mid$])]
+  (tset tokens tok (+ i 0x7f)))
+
+(fn basic [prg]
+  (fn parse-line [line]
+    (local block [:block [:ref :nextline] [:dw (. line 1)]])
+    (each [_ tok (ipairs (lume.slice line 2))]
+      (table.insert block
+        (if (= (type tok) :table) tok
+            (. tokens tok) [:db (. tokens tok)]
+          [:bytes (tostring tok)])))
+    (table.insert block [:db 0])
+    (table.insert block :nextline)
+    block)
+  (fn prg.dat-parser.basic [lines]
+    (local block (prg:new-block))
+    (each [_ line (ipairs (lume.slice lines 2))]
+      (prg:parse-dats block [(parse-line line)]))
+    (prg:parse-dats block [[:dw 0]])
+    block)
+  prg)
+
+(fn loader [prg]
+  (local lprg (basic (asm.new prg)))
+  (local lorg (lprg:org 0x0801))
+  (lorg:append [:basic [10 :call :2061]])
+  (local generator
+    {:chunks []
+     :write
+     (fn [self addr bytes]
+       (local end (+ addr (bytes:len) -1)) ; end address inclusive
+       (lorg:append
+         [:lda #(util.lo addr)] [:sta :0x3c]
+         [:lda #(util.hi addr)] [:sta :0x3d]
+         [:lda #(util.lo end)]  [:sta :0x3e]
+         [:lda #(util.hi end)]  [:sta :0x3f]
+         [:jsr :0xfefd])
+       (table.insert self.chunks bytes))})
+  (prg:upload generator)
+  (lorg:append [:jmp prg.start-symbol])
+  (lprg:assemble)
+  (values lprg generator.chunks))
+
+{: basic : loader}

asm/vm.fnl

@@ -94,6 +94,8 @@
       [:block [:vm :native] [:block ...] [:jsr :interpret]])
     :hotswap-sync
     (fn [self]
+      (if link.machine.stub
+        (do
           (link.machine:stub code1 :next
             [:lda #(lo ($1:lookup-addr :G-POST-HOTSWAP-RESET))]
             [:sta self.IP]
@@ -101,6 +103,7 @@
             [:sta self.IPH]
             [:jmp :next])
           [:vm :debug-stub [:block :G-POST-HOTSWAP-RESET]])
+        [:block]))
   })
 
   (code1:append :next

game/init.fnl

@@ -8,7 +8,7 @@
 (local prg (asm.new))
 ; (prg:debug-to "test.dbg")
 
-(local tiles (prg:org 0x6100))
+(local tiles (prg:org 0x4100))
 (local vm (VM.new prg))
 (local code1 vm.code)
 
@@ -153,7 +153,7 @@
 ; but REPL debug stub should be very available as a task
 
 ; 20x12 means full map is 240 bytes - we have an extra 16 bytes at the end to mess with?
-(tile.appendmaps (prg:org 0x6800))
+(tile.appendmaps (prg:org 0x4800))
 
 (code1:append :main
   [:jsr :reset]
@@ -167,3 +167,4 @@
     :quit])
 
 (prg:assemble)
+

link/init.fnl

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

link/tape.fnl

@@ -0,0 +1,17 @@
+(local tapegen (require :link.tapegen))
+(local tape (require :asm.tape))
+
+(local machine
+  {:source (love.audio.newQueueableSource tapegen.samplerate 16 1 32)
+   :play (fn [self sound] (self.source:queue sound))
+   :stop (fn [self] (love.audio.stop))
+   :upload
+   (fn [self prg]
+     (local (loader chunks) (tape.loader prg))
+     (self:play (tapegen.gen-basic (. loader.org-to-block 0x801 :bytes)))
+     (each [_ chunk (ipairs chunks)]
+       (self:play (tapegen.gen-bin chunk))
+     (love.audio.play self.source)))
+   :connected? (fn [self] true)})
+
+machine

link/tapegen.fnl

@@ -0,0 +1,100 @@
+(local util (require :lib.util))
+(local tape (require :asm.tape))
+
+; https://www.apple.asimov.net/documentation/hardware/io/The%20Apple%20II%20Cassette%20Interface.txt
+
+; header
+; ---+             +-------------+    +-----+
+;    |             |             |    |     |
+;    +-------------+             +----+     |
+
+;    | 1300 microseconds         | 200| 250 |
+; header tone             | synchronous bit |
+
+; 0 and 1 bits
+; +-----+     +----------+          +
+; |     |     |          |          |
+; +     +-----+          +----------+
+
+; |  500 usec |       1000 usec     |
+
+(local samplerate 48000)
+(fn us-to-s [us] (* (/ 1 1000000) us))
+(fn samplecount [us] (* samplerate (us-to-s us)))
+
+(fn checksum [bytes]
+  (var sum 0xff)
+  (for [ibyte 1 (bytes:len)]
+    (set sum (bit.bxor sum (: (bytes:sub ibyte ibyte) :byte))))
+  sum)
+
+(fn data []
+  {:cycles []
+   :samples 0
+   :cycle
+   (fn [self us count]
+     (local samples (samplecount us))
+     (local prev-cycle (. self.cycles (length self.cycles)))
+     (local prev-samples (-?>  prev-cycle (. 1)))
+     (if (= samples prev-samples) (tset prev-cycle 2 (+ (. prev-cycle 2) count))
+       (table.insert self.cycles [samples count]))
+     (set self.samples (+ self.samples (* samples count))))
+   :header
+   (fn [self ?s]
+     (self:cycle (/ 1300 2) (math.floor (/ (or ?s 5) (us-to-s (/ 1300 2)))))
+     (self:cycle 200 1)
+     (self:cycle 250 1))
+   :bit (fn [self on] (self:cycle (if on 500 250) 2))
+   :byte
+   (fn [self byte]
+     (for [ibit 7 0 -1]
+       (self:bit (not= (bit.band byte (bit.lshift 1 ibit)) 0))))
+   :bytes
+   (fn [self bytes]
+     (for [ibyte 1 (bytes:len)]
+       (self:byte (: (bytes:sub ibyte ibyte) :byte))))
+   :bytes-with-checksum
+   (fn [self bytes]
+     (self:bytes bytes)
+     (self:byte (checksum bytes)))
+   :to-sound
+   (fn [self]
+     (local sound (love.sound.newSoundData (+ self.samples (samplecount 8500)) samplerate 16 1))
+     (var isample 0)
+     (var err 0)
+     (var on true)
+     (each [_ [samples count] (ipairs self.cycles)]
+       (for [_ 1 count]
+         (set err (+ err (% samples 1)))
+         (for [_ 1 (+ samples (math.floor err))]
+           (sound:setSample isample (if on 0.75 -0.75))
+           (set isample (+ isample 1)))
+         (set err (% err 1))
+         (set on (not on))))
+     ; finish last bit
+     (set on (not on))
+     (for [_ 1 (samplecount 500)]
+       (sound:setSample isample (if on 0.75 -0.75))
+       (set isample (+ isample 1)))
+     ; add a little pad of zeros
+     (for [_ 1 (samplecount 8000)]
+       (sound:setSample isample 0)
+       (set isample (+ isample 1)))
+     sound)})
+
+(fn gen-bin [bytes ?s-header]
+  (local dat (data))
+  (dat:header ?s-header)
+  (dat:bytes-with-checksum bytes)
+  (dat:to-sound))
+
+(fn gen-basic [bytes ?s-header]
+  (local dat (data))
+  (dat:header ?s-header)
+  (dat:bytes-with-checksum
+    (.. (util.int16-to-bytes (+ (bytes:len) 1)) (util.int8-to-bytes 0xd5)))
+  (dat:header ?s-header)
+  (dat:bytes-with-checksum bytes)
+  (dat:to-sound))
+
+{: gen-bin : gen-basic : checksum : data : samplerate : samplecount}

wrap.fnl

@@ -7,11 +7,12 @@
 (local keymap (require "core.keymap"))
 (local translate (require "core.doc.translate"))
 
-(command.add #(not= link.name :serial) {
+(each [_ linktype (ipairs link.types)]
-  "serial:switch-machine" #(link:switch :serial)
+  (command.add #(not= link.name linktype) {
-})
+    (.. "honeylisp:switch-to-" linktype) #(link:switch linktype)
-(command.add #(not= link.name :gsplus) {
+  }))
-  "gsplus:switch-machine" #(link:switch :gsplus)
+(command.add #(= link.name :tape) {
+  "honeylisp:squelch" #(link.machine:stop)
 })
 (command.add #(link.machine:connected?) {
   "honeylisp:upload" (fn []