diff --git a/asm.fnl b/asm/asm.fnl similarity index 99% rename from asm.fnl rename to asm/asm.fnl index 544c346..23a38a0 100644 --- a/asm.fnl +++ b/asm/asm.fnl @@ -1,5 +1,5 @@ -(local lume (require "lume")) -(local {: int8-to-bytes : int16-to-bytes} (require "util")) +(local lume (require "lib.lume")) +(local {: int8-to-bytes : int16-to-bytes} (require "lib.util")) (local opcodes {}) ; op mode arg diff --git a/vm.fnl b/asm/vm.fnl similarity index 99% rename from vm.fnl rename to asm/vm.fnl index b209e90..267468d 100644 --- a/vm.fnl +++ b/asm/vm.fnl @@ -1,5 +1,5 @@ -(local lume (require "lume")) -(local {: lo : hi} (require "util")) +(local lume (require "lib.lume")) +(local {: lo : hi} (require "lib.util")) (fn inc16-stk [l h] [:block diff --git a/editor/init.fnl b/editor/init.fnl new file mode 100644 index 0000000..ff3420b --- /dev/null +++ b/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" +}) + diff --git a/editor/lite.lua b/editor/lite.lua new file mode 120000 index 0000000..3e4601f --- /dev/null +++ b/editor/lite.lua @@ -0,0 +1 @@ +../../lite/main.lua \ No newline at end of file diff --git a/editor/tileedit.fnl b/editor/tileedit.fnl new file mode 100644 index 0000000..ac7cbf7 --- /dev/null +++ b/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 diff --git a/neut.fnl b/game/init.fnl similarity index 79% rename from neut.fnl rename to game/init.fnl index 8c384f1..fbca100 100644 --- a/neut.fnl +++ b/game/init.fnl @@ -1,7 +1,8 @@ -(local lume (require "lume")) -(local asm (require "asm")) -(local VM (require "vm")) -(local {: lo : hi} (require "util")) +(local lume (require "lib.lume")) +(local asm (require "asm.asm")) +(local VM (require "asm.vm")) +(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! -; TODO: add support to the assembler for enforcing that +; note: the graphical tile data must not cross a page boundary +; (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"]) -(tiles:append :testtile [:bytes "12345678901234567890123456789012"]) -(tiles:append [:bytes "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz"]) -;; 19x11 means full map is 209 bytes +(tile.appendtiles (tile.loadtiles) tiles) +; (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 :testtile [:bytes "12345678901234567890123456789012"]) +; (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) diff --git a/game/tile.fnl b/game/tile.fnl new file mode 100644 index 0000000..190f155 --- /dev/null +++ b/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} + diff --git a/game/tiles.json b/game/tiles.json new file mode 100644 index 0000000..fc58e6c --- /dev/null +++ b/game/tiles.json @@ -0,0 +1 @@ +["000000020A0820202A2020080A02000000010141511105045404051151410100","808080C0C0C0E0C0D0C8C04040404080808083858585828A9282820A08081980","007C0C0C0C0C7C007C7E7EAA88888800001F181818181F001F0F979590909000"] \ No newline at end of file diff --git a/dkjson.lua b/lib/dkjson.lua similarity index 100% rename from dkjson.lua rename to lib/dkjson.lua diff --git a/lume.lua b/lib/lume.lua similarity index 100% rename from lume.lua rename to lib/lume.lua diff --git a/spawn.lua b/lib/spawn.lua similarity index 100% rename from spawn.lua rename to lib/spawn.lua diff --git a/stream.fnl b/lib/stream.fnl similarity index 100% rename from stream.fnl rename to lib/stream.fnl diff --git a/util.fnl b/lib/util.fnl similarity index 72% rename from util.fnl rename to lib/util.fnl index 77218ad..caf4038 100644 --- a/util.fnl +++ b/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} diff --git a/machine.fnl b/link/machine.fnl similarity index 97% rename from machine.fnl rename to link/machine.fnl index 7c09475..2284506 100644 --- a/machine.fnl +++ b/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") diff --git a/serial.fnl b/link/serial.fnl similarity index 100% rename from serial.fnl rename to link/serial.fnl diff --git a/lite.lua b/lite.lua deleted file mode 120000 index c89bd17..0000000 --- a/lite.lua +++ /dev/null @@ -1 +0,0 @@ -../lite/main.lua \ No newline at end of file diff --git a/main.lua b/main.lua index 06b9f29..e09034d 100644 --- a/main.lua +++ b/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 diff --git a/ops.rkt b/ops.rkt deleted file mode 100644 index 8eea927..0000000 --- a/ops.rkt +++ /dev/null @@ -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)]))])) diff --git a/wrap.fnl b/wrap.fnl index e925529..15e7b14 100644 --- a/wrap.fnl +++ b/wrap.fnl @@ -1,9 +1,9 @@ -(require "lite") -(local util (require "util")) -(local lume (require "lume")) +(require "editor") +(local util (require "lib.util")) +(local lume (require "lib.lume")) (local imgui (require "imgui")) -(local serial (require "serial")) -(local gsplus (require "machine")) +(local serial (require "link.serial")) +(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))) ) })