Implement tile editor, reorganize code

This commit is contained in:
Jeremy Penner 2020-10-12 11:48:14 -04:00
parent 3c22f6fe2e
commit 6bf3aa2b91
19 changed files with 212 additions and 222 deletions

View file

@ -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 {}) (local opcodes {})
; op mode arg ; op mode arg

View file

@ -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] (fn inc16-stk [l h]
[:block [:block

24
editor/init.fnl Normal file
View file

@ -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"
})

1
editor/lite.lua Symbolic link
View file

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

117
editor/tileedit.fnl Normal file
View file

@ -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

View file

@ -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)) (local prg (asm.new))
; (prg:debug-to "test.dbg") ; (prg:debug-to "test.dbg")
@ -42,11 +43,13 @@
(vm:for :dup :get :. :inc :inc) :drop) (vm:for :dup :get :. :inc :inc) :drop)
; Graphics routines ; Graphics routines
(vm:def :mixed-hires (vm:def :hires
[:sta :0xc050] [:sta :0xc050]
[:sta :0xc057] [:sta :0xc057]
[:sta :0xc052]) [:sta :0xc052])
(vm:def :mixed [:sta :0xc051])
; starting address: ; starting address:
; 0x2000 + (x*2) + (y%4 * 0x100) + ((y/4) * 0x28) ; 0x2000 + (x*2) + (y%4 * 0x100) + ((y/4) * 0x28)
; x between 0-19 ; x between 0-19
@ -68,8 +71,9 @@
[:sta vm.TOP :x] ; low byte is set [: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 [] (fn draw-block []
[:block [:block
[:clc] [:clc]
@ -141,16 +145,19 @@
[:tya] [:and 0xe0] [:tya] [:and 0xe0]
[:sta vm.TOP :x]) [: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)]) (: (prg:org 0x6800) :append :map [:bytes (string.rep "\0\032\064" 85)])
(code1:append :main (code1:append :main
[:jsr :reset] [:jsr :reset]
[:jsr :interpret] [:jsr :interpret]
[:vm :mixed-hires [:vm :hires; :mixed
:cleargfx :drawmap :cleargfx :drawmap
; 0x0000 :tile>screen 0 :lookup-tile :drawtile
:quit]) :quit])
(prg:assemble) (prg:assemble)

19
game/tile.fnl Normal file
View file

@ -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}

1
game/tiles.json Normal file
View file

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

View file

@ -1,4 +1,5 @@
(local lume (require "lume")) (local lume (require :lib.lume))
(local json (require :lib.dkjson))
(fn string.fromhex [str] (fn string.fromhex [str]
(str:gsub ".." (fn [cc] (string.char (tonumber cc 16))))) (str:gsub ".." (fn [cc] (string.char (tonumber cc 16)))))
@ -36,5 +37,16 @@
(fn swappable-require [modname] (fn swappable-require [modname]
(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}

View file

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

View file

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

View file

@ -3,7 +3,9 @@ fennel = require("lib.fennel")
table.insert(package.loaders, fennel.make_searcher({correlate=true})) table.insert(package.loaders, fennel.make_searcher({correlate=true}))
fv = require("lib.fennelview") fv = require("lib.fennelview")
pp = function(x) print(fv(x)) end 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") luars232 = require("luars232")
_coroutine_resume = coroutine.resume _coroutine_resume = coroutine.resume

192
ops.rkt
View file

@ -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)]))]))

View file

@ -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 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 core (require "core"))
(local command (require "core.command")) (local command (require "core.command"))
(local keymap (require "core.keymap")) (local keymap (require "core.keymap"))
@ -19,12 +19,12 @@
}) })
(command.add #(machine:connected?) { (command.add #(machine:connected?) {
"honeylisp:upload" (fn [] "honeylisp:upload" (fn []
(local p (util.reload "neut")) (local p (util.reload "game"))
(p:upload machine) (p:upload machine)
(core.log (string.format "%x" (p:lookup-addr p.start-symbol)))) (core.log (string.format "%x" (p:lookup-addr p.start-symbol))))
}) })
(command.add (fn [] true) { (command.add (fn [] true) {
"honeylisp:rebuild" #(util.reload "neut") "honeylisp:rebuild" #(util.reload "game")
}) })
(fn selected-symbol [] (fn selected-symbol []
@ -56,7 +56,7 @@
(when (not= err nil) (print err) (error err))) (when (not= err nil) (print err) (error err)))
"honeylisp:address" (fn [] "honeylisp:address" (fn []
(local word (selected-symbol)) (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))) (core.log (string.format "%s %x" word (or (p:lookup-addr word) -1)))
) )
}) })