Compare commits

...

72 commits
main ... nabu

Author SHA1 Message Date
Jeremy Penner fb0c141653 Fix a couple bugs in z80 assembly, support addresses + function args 2023-02-22 00:06:04 -05:00
Jeremy Penner 4f40b3851b Upgrade to Fennel 1.3.0, z80 assembly support 2023-02-20 19:50:02 -05:00
Jeremy Penner 8f6a214d83 git subrepo push --remote=git@github.com:jeremypenner/lite vendor/lite
subrepo:
  subdir:   "vendor/lite"
  merged:   "384d54f"
upstream:
  origin:   "git@github.com:jeremypenner/lite"
  branch:   "master"
  commit:   "384d54f"
git-subrepo:
  version:  "0.4.3"
  origin:   "???"
  commit:   "???"
2022-01-07 12:58:17 -05:00
Jeremy Penner 3a4d6ff460 outline tile that will be changed when editing, fix tile list 2021-12-29 17:15:37 -06:00
Jeremy Penner b0db9a10a1 highlight active layer when mousing over map, fix layout 2021-12-27 20:11:09 -06:00
Jeremy Penner 2c06782600 show all map layers at once 2021-12-27 16:59:00 -06:00
Jeremy Penner d01ec40181 deprecate imstate 2021-12-26 21:00:00 -06:00
Jeremy Penner d17ae7873f fix font and portrait editor 2021-12-26 15:37:30 -06:00
Jeremy Penner 7b6893d6e3 deprecate gfxedit2 2021-12-26 14:04:34 -06:00
Jeremy Penner e6eee86a91 Move repl / inspector to new imgui
* make views pin scrolling to bottom
* support multiline labels (no wordwrap yet)
* always expand groups (don't clear after populating form)
2021-12-25 13:26:00 -06:00
Jeremy Penner 45e78e298e move 8bitsy editor to new imgui, add label widget 2021-12-24 17:08:01 -06:00
Jeremy Penner 8aa79a4c2d refactor layout API 2021-12-23 22:36:20 -06:00
Jeremy Penner a9b54cc890 Fix mapedit layout, add inspector helper function for when pretty-print debugging is ugly 2021-12-22 15:36:29 -06:00
Jeremy Penner 939cfc6065 First cut at updating mapedit 2021-12-21 21:04:43 -06:00
Jeremy Penner b9ec214b46 widget grouping mechanism 2021-12-21 09:45:45 -06:00
Jeremy Penner e711557fdf fix textbox styling 2021-12-21 09:41:15 -06:00
Jeremy Penner 8b646eac4b update tile selector to use horiz-wrapper layout 2021-12-21 09:36:38 -06:00
Jeremy Penner f81dd88a52 rewrite imgui, tile editor 2021-12-20 20:40:18 -05:00
Jeremy Penner d070e8adb0 debugging udp 2021-12-20 12:25:28 -05:00
Jeremy Penner 3e87f231bc fix test program 2021-12-11 13:51:31 -05:00
Jeremy Penner 38023f8828 fix map label offset, some more tiles 2021-11-22 01:15:52 -05:00
Jeremy Penner de6ac91c95 upgrade to Fennel 1.0 2021-11-21 20:23:12 -05:00
Jeremy Penner 8d97344643 somewhat better layered maps, simpler serialization 2021-11-17 21:46:38 -05:00
Jeremy Penner 18f62e89b9 Multiple tile-style support, layered maps 2021-11-14 14:55:41 -05:00
Jeremy Penner fe00a91064 hot code reload works on hardware!! 2021-10-10 22:15:11 -04:00
Jeremy Penner e8665e7c0a Fix multiple breakpoints at the same memory address 2021-10-07 22:16:09 -04:00
Jeremy Penner 06ccd4a2b3 preserve globals across hot reloads why doncha 2021-10-04 22:00:14 -04:00
Jeremy Penner e11241eb10 Hotswap works in MAME (once)! 2021-10-04 21:22:48 -04:00
Jeremy Penner 4d0beb0dbe * Capture callsite details
* refactor "jump" command into "eval"
* Add debug server task to program
* Allow compiling overlay programs that assume the existing program is already in memory
* Add "forever" form to generate optimized infinite loops
* Handle client changing its udp port
2021-10-03 11:45:25 -04:00
Jeremy Penner 2df2abe543 udp message queue to make write wait for confirmation 2021-09-30 22:25:04 -04:00
Jeremy Penner 9ec998e128 IT WORKS 2021-09-28 20:19:13 -04:00
Jeremy Penner 3f295581f5 whoops, missed some stuff 2021-09-26 23:21:57 -04:00
Jeremy Penner 2f59db6766 Implement string constants, buffers, macro barriers
macro barriers are a hack to say "this form does its own macroexpansion
internally" so that we can have state-smart macros that expand to
different values depending on if they are being used in code or in a
function definition. This seems like a real bad design choice but I
can't think of a better one right now!

(not quite true: the better design choice is to allow forms to return
opgens, and then define a :bytes form that returns the address of the
generated thing. :bytes could be understood by :buffer directly.
But that's... complicated.)
2021-09-26 23:07:36 -04:00
Jeremy Penner 6a92211024 Implement macros, symbol expansion (replaces constants, getters) 2021-09-26 20:32:17 -04:00
Jeremy Penner 5e46b908bd refactor set!, byte-at, word-at, long-at 2021-09-26 00:34:48 -04:00
Jeremy Penner 683296b4e8 iigs: tested, unworking uthernet-ii debug stub 2021-09-25 14:53:18 -04:00
Jeremy Penner ccfb52aeaa iigs: untested uthernet-ii debug stub
65816: support 8-bit immediate mode
repl: add re-run and clear buttons
ssc: fix returning false from an else clause
     add byteswap, byte reads / writes
     start stdlib with memcpy
2021-09-23 22:28:48 -04:00
Jeremy Penner c0160c7018 isometric experiments 2021-09-13 23:16:03 -04:00
Jeremy Penner 432a4fa26a Sprite compiler!!! had to redraw my tiles 2021-09-12 00:18:21 -04:00
Jeremy Penner d2ff69258f implement draw-object & pei slamming
asm: allow computed addresses, not just immediate mode values
map llissp source to assembly
2021-09-10 22:55:47 -04:00
Jeremy Penner ba03b74278 full-screen draw speed test 2021-09-06 23:23:45 -04:00
Jeremy Penner a03c8b2865 Tiledraw rewrite for speed and size, locals bugfix 2021-09-06 00:19:22 -04:00
Jeremy Penner 7a3436dc7e I'm drawing lots of tiles!! also support locals in inline asm 2021-09-05 23:29:16 -04:00
Jeremy Penner f833e62d91 I'm drawing a tile!! 2021-09-01 22:59:55 -04:00
Jeremy Penner dc61bb08e0 iigs tile editing basically works 2021-08-28 22:04:54 -04:00
Jeremy Penner f54ebea6bc platform-specific tile editor 2021-08-24 21:24:06 -04:00
Jeremy Penner b2d374622a preserve 0x1xx stack for main task, and restore on quit 2021-08-20 22:29:21 -04:00
Jeremy Penner c428ef3d9c Multitasking 2021-08-19 23:51:12 -04:00
Jeremy Penner 64281801b2 Show LINE NUMBERS in compiler errors!! 2021-08-18 22:19:57 -04:00
Jeremy Penner bee38a4168 whoooooops, broke that 2021-08-16 22:14:48 -04:00
Jeremy Penner 7caf47ae37 improve gen-condition comparisons codegen for simple 32-bit cases 2021-08-16 22:12:26 -04:00
Jeremy Penner 6eec75d5f2 allow using opgen for reading longs from places besides the DP long "register" 2021-08-16 19:05:53 -04:00
Jeremy Penner 315fd794de Working boot stub to initialize the Memory Manager toolset without an OS
Listen to keyboard events
2021-08-15 22:40:47 -04:00
Jeremy Penner e84fbd2c95 constants, getters, setters, true, false. I should start making stuff!! 2021-08-14 20:52:43 -04:00
Jeremy Penner 48f181bd32 some more toolbox routines, small fixes 2021-08-12 22:06:31 -04:00
Jeremy Penner 3c3d2ffd6b oh yeah xor 2021-08-11 23:59:04 -04:00
Jeremy Penner 81ea4a4410 bitwise ops, unary negation 2021-08-11 23:54:37 -04:00
Jeremy Penner 65101ad21d Implement while loop 2021-08-11 23:06:31 -04:00
Jeremy Penner 8eef9e49b8 Fix conditionals! And optimize the hell out of them! 2021-08-11 22:34:07 -04:00
Jeremy Penner 1eea56bb5b Add globals, test various pointer setting 2021-08-10 13:23:09 -04:00
Jeremy Penner 8a211365e4 Better pointer handling, implement set! 2021-08-10 00:33:54 -04:00
Jeremy Penner 29de142c4a Fix toolbox, start to handle pointers 2021-08-09 14:43:24 -04:00
Jeremy Penner b63573cc89 32-bit support!! toolbox is currently broken but the main compiler seems to have stabilized 2021-08-08 21:58:49 -04:00
Jeremy Penner cd4bf59b41 Toolbox support - we can print numbers!! 2021-08-05 21:30:08 -04:00
Jeremy Penner 16d88efbf1 We can add numbers!! (confirmed in MAME debugger) 2021-08-02 19:40:31 -04:00
Jeremy Penner e37a7a2153 Implement the Sufficiently Simple Syntax macro, some cleanup 2021-08-02 14:49:29 -04:00
Jeremy Penner 5bf35209be Upgrade to Fennel 0.9.2 2021-08-02 14:48:01 -04:00
Jeremy Penner ad219ba221 Conditionals, functions 2021-08-01 23:26:51 -04:00
Jeremy Penner 4cd52d202e Clean up expression logic, implement local variables 2021-08-01 18:45:54 -04:00
Jeremy Penner 58a80f982f Beginnings of the Sufficiently Simple Compiler - it can add numbers! 2021-07-31 19:50:47 -04:00
Jeremy Penner b6db098a70 Factor out 6502 into its own module, generalize asm, complete 65816?? 2021-07-30 21:57:38 -04:00
Jeremy Penner 6738dd8ec4 First tentative steps into 65816 support 2021-07-30 19:03:15 -04:00
54 changed files with 7661 additions and 2742 deletions

BIN
UdpDebug.dsk Normal file

Binary file not shown.

128
asm/6502.fnl Normal file
View file

@ -0,0 +1,128 @@
(local {: int8-to-bytes : int16-to-bytes} (require "lib.util"))
(local opcodes {})
; op mode arg
; single-byte ops
(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 :rti 0x40 :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}]
(each [opcode byte (pairs ops)]
(tset opcodes opcode (fn [mode] (if (= mode :rel) byte nil)))))
(set opcodes.jsr (fn [mode] (if (= mode :abs) 0x20 nil)))
; aaabbbcc ops
(fn aaabbbcc [aaa cc modemap]
(local base (bit.bor cc (bit.lshift aaa 5)))
(fn [mode]
(local bbb (. modemap mode))
(if bbb (bit.bor base (bit.lshift bbb 2)) nil)))
(fn indexed-modes [...]
(let [modemap {}]
(each [index mode (pairs [...])]
(tset modemap mode (- index 1)))
modemap))
(fn without-modes [modemap ...]
(let [newmodemap (lume.clone modemap)]
(each [_ mode (pairs [...])]
(tset newmodemap mode nil))
newmodemap))
(fn only-modes [modemap ...]
(let [newmodemap {}]
(each [_ mode (pairs [...])]
(tset newmodemap mode (. modemap mode)))
newmodemap))
; cc=1 ops
(let [cc1-modes (indexed-modes :zp-x* :zp :imm :abs :zp*-y :zp-x :abs-y :abs-x)
ops {:ora 0 :and 1 :eor 2 :adc 3 :lda 5 :cmp 6 :sbc 7}]
(each [opcode aaa (pairs ops)]
(tset opcodes opcode (aaabbbcc aaa 1 cc1-modes))
(tset opcodes :sta (aaabbbcc 4 1 (without-modes cc1-modes :imm)))))
; cc=2 ops
(let [cc2-modes (indexed-modes nil :zp :a :abs nil :zp-x nil :abs-x)]
(each [opcode aaa (pairs {:asl 0 :rol 1 :lsr 2 :ror 3})]
(tset opcodes opcode (aaabbbcc aaa 2 cc2-modes))
(each [opcode aaa (pairs {:dec 6 :inc 7})]
(tset opcodes opcode (aaabbbcc aaa 2 (without-modes cc2-modes :a))))))
(tset opcodes :stx (aaabbbcc 4 2 (indexed-modes nil :zp nil :abs nil nil :zp-y)))
(tset opcodes :ldx (aaabbbcc 5 2 (indexed-modes :imm :zp nil :abs nil nil :zp-y nil :abs-y)))
; cc=0 ops
(let [cc0-modes (indexed-modes :imm :zp nil :abs nil :zp-x nil :abs-x)]
(tset opcodes :bit (aaabbbcc 1 0 (only-modes cc0-modes :zp :abs)))
(tset opcodes :sty (aaabbbcc 4 0 (only-modes cc0-modes :zp :abs :zp-x)))
(tset opcodes :ldy (aaabbbcc 5 0 cc0-modes))
(each [opcode aaa (pairs {:cpy 6 :cpx 7})]
(tset opcodes opcode (aaabbbcc aaa 0 (only-modes cc0-modes :imm :zp :abs)))))
(tset opcodes :jmp (fn [mode] (match mode :abs 0x4c :abs* 0x6c _ nil)))
(fn parse-mode-arg [op]
(match op
[_ :a] [:a nil]
([_ imm] ? (or (= (type imm) "number") (= (type imm) "function"))) [:imm imm]
([opcode addr] ? (and (= (type addr) "string") (= (opcode:sub 1 1) "b"))) [:rel addr] ; branch
[_ addr :x] [:addr-x addr]
[_ [addr] :y] [:zp*-y addr]
[_ addr :y] [:addr-y addr]
[_ [addr :x]] [:zp-x* addr]
([_ addr] ? (= (type addr) "string")) [:addr addr]
[_ [addr]] [:abs* addr]
[_] [nil nil]
_ (error (.. "Unrecognized syntax" (fv op)))))
(fn parse-op [op]
(let [[mode arg] (parse-mode-arg op)] {: mode : arg}))
(local op-pdat {})
(fn is-zp? [env name]
(match (env:lookup-org name)
org (< org 0x100)))
(fn op-pdat.patch [op env]
(when (and op.mode (= (op.mode:sub 1 4) :addr))
(let [zp-mode (.. :zp (op.mode:sub 5))
abs-mode (.. :abs (op.mode:sub 5))
is-zp (and ((. opcodes op.opcode) zp-mode) (is-zp? env op.arg))]
(set op.mode (if is-zp zp-mode abs-mode)))))
(fn op-pdat.size [{: mode}]
(if
(or (= mode nil) (= mode :a)) 1
(= (mode:sub 1 3) :abs) 3
2))
(fn op-pdat.bytes [op env]
(local bytegen (. opcodes op.opcode))
; (pp op)
(if bytegen
(let [opbyte (bytegen op.mode)
argbytes
(if
(and (= op.mode :imm) (= (type op.arg) "function"))
(int8-to-bytes (op.arg env))
(= op.mode :imm) (int8-to-bytes op.arg)
(= op.mode :rel)
(int8-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 2)))
(= (op-pdat.size op) 2) (int8-to-bytes (env:lookup-addr op.arg))
(= (op-pdat.size op) 3) (int16-to-bytes (env:lookup-addr op.arg))
"")]
(if opbyte
(.. (int8-to-bytes opbyte) argbytes)
(error (.. op.opcode " doesn't support mode " op.mode))))
""))
{: opcodes : op-pdat : parse-op}

149
asm/65816.fnl Normal file
View file

@ -0,0 +1,149 @@
(local {: int8-to-bytes : int16-to-bytes : int24-to-bytes} (require "lib.util"))
(local opcodes {})
; http://www.oxyron.de/html/opcodes816.html
; The 65816 has an opcode for every possible byte. Rather than implementing any kind of tricky encoder logic, we just build a lookup table directly.
(let [ops [[:brk nil] [:ora :idx] [:cop :imm] [:ora :sr] [:tsb :dp] [:ora :dp] [:asl :dp] [:ora :idl] ; 0x00-0x07
[:php nil] [:ora :imm] [:asl nil] [:phd nil] [:tsb :abs] [:ora :abs] [:asl :abs] [:ora :abl] ; 0x08-0x0f
[:bpl :rel] [:ora :idy] [:ora :idp] [:ora :isy] [:trb :dp] [:ora :dpx] [:asl :dpx] [:ora :idly] ; 0x10-0x17
[:clc nil] [:ora :aby] [:inc nil] [:tcs nil] [:trb :abs] [:ora :abx] [:asl :abx] [:ora :alx] ; 0x18-0x1f
[:jsr :abs] [:and :idx] [:jsr :abl] [:and :sr] [:bit :dp] [:and :dp] [:rol :dp] [:and :idl] ; 0x20-0x27
[:plp nil] [:and :imm] [:rol nil] [:pld nil] [:bit :abs] [:and :abs] [:rol :abs] [:and :abl] ; 0x28-0x2f
[:bmi :rel] [:and :idy] [:and :idp] [:and :isy] [:bit :dpx] [:and :dpx] [:rol :dpx] [:and :idly] ; 0x30-0x37
[:sec nil] [:and :aby] [:dec nil] [:tsc nil] [:bit :abx] [:and :abx] [:rol :abx] [:and :alx] ; 0x38-0x3f
[:rti nil] [:eor :idx] [:wdm nil] [:eor :sr] [:mvp :bm] [:eor :dp] [:lsr :dp] [:eor :idl] ; 0x40-0x47
[:pha nil] [:eor :imm] [:lsr nil] [:phk nil] [:jmp :abs] [:eor :abs] [:lsr :abs] [:eor :abl] ; 0x48-0x4f
[:bvc :rel] [:eor :idy] [:eor :idp] [:eor :isy] [:mvn :bm] [:eor :dpx] [:lsr :dpx] [:eor :idly] ; 0x50-0x57
[:cli nil] [:eor :aby] [:phy nil] [:tcd nil] [:jmp :abl] [:eor :abx] [:lsr :abx] [:eor :alx] ; 0x58-0x5f
[:rts nil] [:adc :idx] [:per :rell] [:adc :sr] [:stz :dp] [:adc :dp] [:ror :zp] [:adc :idl] ; 0x60-0x67
[:pla nil] [:adc :imm] [:ror nil] [:rtl nil] [:jmp :ind] [:adc :abs] [:ror :abs] [:adc :abl] ; 0x68-0x6f
[:bvs :rel] [:adc :idy] [:adc :idp] [:adc :isy] [:stz :dpx] [:adc :dpx] [:ror :zpx] [:adc :idly] ; 0x70-0x77
[:sei nil] [:adc :aby] [:ply nil] [:tdc nil] [:jmp :iax] [:adc :abx] [:ror :abx] [:adc :alx] ; 0x78-0x7f
[:bra :rel] [:sta :idx] [:brl :rell] [:sta :sr] [:sty :dp] [:sta :dp] [:stx :dp] [:sta :idl] ; 0x80-0x87
[:dey nil] [:bit :imm] [:txa nil] [:phb nil] [:sty :abs] [:sta :abs] [:stx :abs] [:sta :abl] ; 0x88-0x8f
[:bcc :rel] [:sta :idy] [:sta :idp] [:sta :isy] [:sty :dpx] [:sta :dpx] [:stx :dpy] [:sta :idly] ; 0x90-0x97
[:tya nil] [:sta :aby] [:txs nil] [:txy nil] [:stz :abs] [:sta :abx] [:stz :abx] [:sta :alx] ; 0x98-0x9f
[:ldy :imm] [:lda :idx] [:ldx :imm] [:lda :sr] [:ldy :dp] [:lda :dp] [:ldx :dp] [:lda :idl] ; 0xa0-0xa7
[:tay nil] [:lda :imm] [:tax nil] [:plb nil] [:ldy :abs] [:lda :abs] [:ldx :abs] [:lda :abl] ; 0xa8-0xaf
[:bcs :rel] [:lda :idy] [:lda :idp] [:lda :isy] [:ldy :dpx] [:lda :dpx] [:ldx :dpy] [:lda :idly] ; 0xb0-0xb7
[:clv nil] [:lda :aby] [:tsx nil] [:tyx nil] [:ldy :abx] [:lda :abx] [:ldx :aby] [:lda :alx] ; 0xb8-0xbf
[:cpy :imm] [:cmp :idx] [:rep :imm] [:cmp :sr] [:cpy :dp] [:cmp :dp] [:dec :dp] [:cmp :idl] ; 0xc0-0xc7
[:iny nil] [:cmp :imm] [:dex nil] [:wai nil] [:cpy :abs] [:cmp :abs] [:dec :abs] [:cmp :abl] ; 0xc8-0xcf
[:bne :rel] [:cmp :idy] [:cmp :idp] [:cmp :isy] [:pei :idp] [:cmp :dpx] [:dec :dpx] [:cmp :idly] ; 0xd0-0xd7
[:cld nil] [:cmp :aby] [:phx nil] [:stp nil] [:jmp :ial] [:cmp :abx] [:dec :abx] [:cmp :alx] ; 0xd8-0xdf
[:cpx :imm] [:sbc :idx] [:sep :imm] [:sbc :sr] [:cpx :dp] [:sbc :dp] [:inc :dp] [:sbc :idl] ; 0xe0-0xe7
[:inx nil] [:sbc :imm] [:nop nil] [:xba nil] [:cpx :abs] [:sbc :abs] [:inc :abs] [:sbc :abl] ; 0xe8-0xef
[:beq :rel] [:sbc :idy] [:sbc :idp] [:sbc :isy] [:pea :imm] [:sbc :dpx] [:inc :dpx] [:sbc :idly] ; 0xf0-0xf7
[:sed nil] [:sbc :aby] [:plx nil] [:xce nil] [:jsr :iax] [:sbc :abx] [:inc :abx] [:sbc :alx] ; 0xf8-0xff
]
mnemonic-to-modemap {}]
(each [iop [mnemonic mode] (ipairs ops)]
(when (= (. mnemonic-to-modemap mnemonic) nil)
(tset mnemonic-to-modemap mnemonic {}))
(tset mnemonic-to-modemap mnemonic (or mode :nil) (- iop 1)))
(each [mnemonic modemap (pairs mnemonic-to-modemap)]
(tset opcodes mnemonic (fn [mode] (. modemap (or mode :nil))))))
(set opcodes.jsl #(when (= $1 :abl) 0x22)) ; allow forced long subroutine calls
(fn dp-addr [addr]
(when (and (= (type addr) :string) (= (addr:sub 1 1) :d))
(tonumber (addr:sub 2))))
(fn addr-parser [addr] (or (dp-addr addr) (tonumber addr)))
(fn explicit-mode-arg [arg]
(var result nil)
(when (= (type arg) :table)
(each [mode arg (pairs arg)]
(when (= (type mode) :string)
(set result [mode arg]))))
result)
(fn parse-mode-arg [op]
(match op
(where [_ arg] (explicit-mode-arg arg)) (explicit-mode-arg arg)
(where [mvx srcbank dstbank]
(= (type srcbank) :number) (= (type dstbank) :number) (= (mvx:sub 1 2) :mv))
[:bm [dstbank srcbank]] ; encoded backwards for some reason
[_ offset :s] [:sr offset]
[_ :#8 imm] [:imm8 imm]
(where [_ imm] (or (= (type imm) :number) (= (type imm) :function))) [:imm imm]
[_ [[addr]] :y] [:idly addr]
[_ [addr :s] :y] [:isy addr]
[_ [addr] :y] [:idy addr]
; can tell ial / idl apart by the mnemonic
[:jmp [[addr]]] [:ial addr]
[_ [[addr]]] [:idl addr]
; can tell iax / idx apart by the mnemonic
[:jmp [addr :x]] [:iax addr]
[:jsr [addr :x]] [:iax addr]
[_ [addr :x]] [:idx addr]
; rell is the only valid mode for two mnemonics
[:per addr] [:rell addr]
[:brl addr] [:rell addr]
; rel is the only valid mode for other branches
(where [br addr] (= (type addr) "string") (= (br:sub 1 1) "b") (not= br :bit)) [:rel addr]
(where [_ addr :x] (dp-addr addr)) [:dpx addr]
(where [_ addr :y] (dp-addr addr)) [:dpy addr]
(where [_ [addr]] (dp-addr addr)) [:idp addr]
(where [_ addr] (dp-addr addr)) [:dp addr]
[_ [addr]] [:ind addr]
[_ addr :y] [:aby addr]
[:jsl addr] [:abl addr] ; jsl is always long
; we'll assume local bank for now and fix up bankswitching in :patch
[_ addr :x] [:abx addr]
[_ addr] [:abs addr]
[_] [nil nil]
_ (error (.. "Unrecognized syntax" (fv op)))))
(fn parse-op [op]
(let [[mode arg] (parse-mode-arg op)] {: mode : arg}))
; abl = $000000
; alx = $000000,X
(local op-pdat {})
(fn addr-page [addr] (math.floor (/ addr 0x10000)))
(fn op-pdat.patch [op env]
(local long-mode (match op.mode :abs :abl :abx :alx))
(when (and long-mode
(not= (type op.arg) :function)
(not= (addr-page (env:lookup-org op.arg))
(addr-page env.root-block.org)))
(set op.mode long-mode)))
(fn op-pdat.size [op env]
; TODO: handle 8-bit modes
(match op.mode
(where (or :sr :dp :dpx :dpy :idp :idx :idy :idl :idly :isy :rel)) 2
:imm8 2
:imm (match op.opcode
(where (or :cop :brk :sep :rep)) 2
_ 3)
(where (or :abs :abx :aby :ind :iax :rell :bm)) 3
(where (or :abl :alx :ial)) 4
nil 1
_ (error (.. "unknown mode " op.mode))))
(fn op-pdat.bytes [op env]
(local bytegen (. opcodes op.opcode))
(if bytegen
(let [opbyte (bytegen (if (= op.mode :imm8) :imm op.mode))
arg (if (= (type op.arg) :function) (op.arg env) op.arg)
argbytes
(if
(or (= op.mode :sr) (= op.mode :isy) (= op.mode :imm8)) (int8-to-bytes arg)
(= op.mode :bm) (.. (int8-to-bytes (. arg 1)) (int8-to-bytes (. arg 2)))
(and (= op.mode :imm) (= (op-pdat.size op env) 3)) (int16-to-bytes arg)
(and (= op.mode :imm) (= (op-pdat.size op env) 2)) (int8-to-bytes arg)
(= op.mode :rel) (int8-to-bytes (- (env:lookup-addr arg) (+ op.addr 2)))
(= op.mode :rell) (int16-to-bytes (- (env:lookup-addr arg) (+ op.addr 3)))
(= (op-pdat.size op env) 2) (int8-to-bytes (env:lookup-addr arg))
(= (op-pdat.size op env) 3) (int16-to-bytes (env:lookup-addr arg))
(= (op-pdat.size op env) 4) (int24-to-bytes (env:lookup-addr arg))
"")]
(if opbyte
(.. (int8-to-bytes opbyte) argbytes)
(error (.. op.opcode " doesn't support mode " op.mode))))
""))
{: opcodes : parse-op : op-pdat : addr-parser}

View file

@ -1,98 +1,16 @@
(local lume (require "lib.lume"))
(local {: int8-to-bytes : int16-to-bytes} (require "lib.util"))
(local opcodes {})
; op mode arg
; single-byte ops
(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 :rti 0x40 :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}]
(each [opcode byte (pairs ops)]
(tset opcodes opcode (fn [mode] (if (= mode :rel) byte nil)))))
(set opcodes.jsr (fn [mode] (if (= mode :abs) 0x20 nil)))
; aaabbbcc ops
(fn aaabbbcc [aaa cc modemap]
(local base (bit.bor cc (bit.lshift aaa 5)))
(fn [mode]
(local bbb (. modemap mode))
(if bbb (bit.bor base (bit.lshift bbb 2)) nil)))
(fn indexed-modes [...]
(let [modemap {}]
(each [index mode (pairs [...])]
(tset modemap mode (- index 1)))
modemap))
(fn without-modes [modemap ...]
(let [newmodemap (lume.clone modemap)]
(each [_ mode (pairs [...])]
(tset newmodemap mode nil))
newmodemap))
(fn only-modes [modemap ...]
(let [newmodemap {}]
(each [_ mode (pairs [...])]
(tset newmodemap mode (. modemap mode)))
newmodemap))
; cc=1 ops
(let [cc1-modes (indexed-modes :zp-x* :zp :imm :abs :zp*-y :zp-x :abs-y :abs-x)
ops {:ora 0 :and 1 :eor 2 :adc 3 :lda 5 :cmp 6 :sbc 7}]
(each [opcode aaa (pairs ops)]
(tset opcodes opcode (aaabbbcc aaa 1 cc1-modes))
(tset opcodes :sta (aaabbbcc 4 1 (without-modes cc1-modes :imm)))))
; cc=2 ops
(let [cc2-modes (indexed-modes nil :zp :a :abs nil :zp-x nil :abs-x)]
(each [opcode aaa (pairs {:asl 0 :rol 1 :lsr 2 :ror 3})]
(tset opcodes opcode (aaabbbcc aaa 2 cc2-modes))
(each [opcode aaa (pairs {:dec 6 :inc 7})]
(tset opcodes opcode (aaabbbcc aaa 2 (without-modes cc2-modes :a))))))
(tset opcodes :stx (aaabbbcc 4 2 (indexed-modes nil :zp nil :abs nil nil :zp-y)))
(tset opcodes :ldx (aaabbbcc 5 2 (indexed-modes :imm :zp nil :abs nil nil :zp-y nil :abs-y)))
; cc=0 ops
(let [cc0-modes (indexed-modes :imm :zp nil :abs nil :zp-x nil :abs-x)]
(tset opcodes :bit (aaabbbcc 1 0 (only-modes cc0-modes :zp :abs)))
(tset opcodes :sty (aaabbbcc 4 0 (only-modes cc0-modes :zp :abs :zp-x)))
(tset opcodes :ldy (aaabbbcc 5 0 cc0-modes))
(each [opcode aaa (pairs {:cpy 6 :cpx 7})]
(tset opcodes opcode (aaabbbcc aaa 0 (only-modes cc0-modes :imm :zp :abs)))))
(tset opcodes :jmp (fn [mode] (match mode :abs 0x4c :abs* 0x6c _ nil)))
(fn size [mode]
(if
(or (= mode nil) (= mode :a)) 1
(= (mode:sub 1 3) :abs) 3
2))
(fn opsize [op] (if (= op.opcode :block) 0 (size op.mode)))
(fn parse-mode-arg [op]
(match op
[_ :a] [:a nil]
([_ imm] ? (or (= (type imm) "number") (= (type imm) "function"))) [:imm imm]
([opcode addr] ? (and (= (type addr) "string") (= (opcode:sub 1 1) "b"))) [:rel addr] ; branch
[_ addr :x] [:addr-x addr]
[_ [addr] :y] [:zp*-y addr]
[_ addr :y] [:addr-y addr]
[_ [addr :x]] [:zp-x* addr]
([_ addr] ? (= (type addr) "string")) [:addr addr]
[_ [addr]] [:abs* addr]
[_] [nil nil]
_ (error (.. "Unrecognized syntax" (fv op)))))
(local {: int8-to-bytes : int16-to-bytes : int24-to-bytes : int32-to-bytes} (require "lib.util"))
(fn make-env [block parent]
{:parent parent
:prg (or parent.prg parent)
:root-block (or parent.root-block block)
:block block
; todo: support local self-reference if org is set to zp
:is-zp? (fn [self name] (if (. self.block.symbols name) false (self.parent:is-zp? name)))
:lookup-org
(fn [self name]
(if (or (. self.block.symbols name) (. self.block.globals name))
self.root-block.org
(self.parent:lookup-org name)))
:lookup-addr
(fn [self name]
(local ipdat (. self.block.symbols name))
@ -110,7 +28,8 @@
(self.parent:lookup-addr name)))})
(fn program [prg-base]
(fn program [prg-base ?processor]
(local {: opcodes : op-pdat : parse-op : addr-parser} (require (.. :asm. (or ?processor :6502))))
; dat - anything that takes up space in the assembled output (op, dw, db, etc)
; takes the form [:op args]
; pdat - a parsed dat; takes the form {:type type :addr addr ...}
@ -130,11 +49,14 @@
(let [opcode (. dat 1)
parser (. dat-parser opcode)
meta (getmetatable dat)
pdat
(if parser (parser dat block)
(. opcodes opcode) (dat-parser.op dat)
(error (.. "Unrecognized opcode " (fv opcode))))]
(when pdat
(when meta (set block.last-meta meta))
(set pdat.meta block.last-meta)
(set pdat.nearest-symbol block.last-symbol)
(table.insert block.pdats pdat)
(when pdat.globals
@ -146,18 +68,18 @@
block)
(fn dat-parser.op [op]
(let [[mode arg] (parse-mode-arg op)]
{:type :op :opcode (. op 1) : mode : arg}))
(lume.extend {:type :op :opcode (. op 1)} (parse-op op)))
(fn dat-parser.block [block]
(let [dats (lume.clone block)]
(table.remove dats 1)
(parse-dats (new-block block.last-symbol) dats)))
(fn dat-parser.db [db] {:type :var :init (. db 2) :size 1})
(fn dat-parser.dw [dw] {:type :var :init (. dw 2) :size 2})
(fn dat-parser.bytes [bytes] {:type :raw :bytes (. bytes 2)})
(fn dat-parser.ref [ref] {:type :ref :target (. ref 2)})
(fn dat-parser.db [db] {:type :var :init (. db 2) :size 1})
(fn dat-parser.dw [dw] {:type :var :init (. dw 2) :size 2})
(fn dat-parser.dl [dl] {:type :var :init (. dl 2) :size 4})
(fn dat-parser.bytes [[_ bytes]] {:type :raw :bytes (if (= (type bytes) :table) (string.char (table.unpack bytes)) bytes)})
(fn dat-parser.ref [ref] {:type :ref :target (. ref 2)})
(fn dat-parser.flatten [flat block]
(parse-dats block (lume.slice flat 2))
nil)
@ -169,6 +91,7 @@
nil)
(fn dat-parser.align [pad] {:type :pad :align (. pad 2)})
(fn dat-parser.meta [[_ f]] {:type :meta :bytes "" :size 0 : f})
(fn dat-parser.hot-preserve [[_ label & dats] block]
(let [preserve-block (new-block)]
(tset block.preserved label preserve-block)
@ -178,56 +101,33 @@
preserve-block))
(local pdat-processor {
:op {}
:op op-pdat
:var {}
:ref {}
:raw {}
:block {}
:pad {}
:meta {}
})
(fn describe-pdat [pdat]
(if pdat.meta (.. pdat.meta.filename "@" pdat.meta.line)
(.. (or pdat.nearest-symbol "<start of block>") " @" (or pdat.addr "<no address>"))))
(fn process-pdat [pdat process default ...]
(fn complain [ok ...]
(if ok (values ...)
(do (error (.. process " failed in " pdat.type " near " (or pdat.nearest-symbol "<start of block>") " @" (or pdat.addr "<no address>") " - " ...)))))
(do (error (.. process " failed in " pdat.type " near " (describe-pdat pdat) " - " ...)))))
(local processor (. pdat-processor pdat.type process))
(if processor (complain (pcall #(processor pdat $...) ...)) default))
(fn pdat-processor.op.patch [op env]
(when (and op.mode (= (op.mode:sub 1 4) :addr))
(let [zp-mode (.. :zp (op.mode:sub 5))
abs-mode (.. :abs (op.mode:sub 5))
is-zp (and ((. opcodes op.opcode) zp-mode) (env:is-zp? op.arg))]
(set op.mode (if is-zp zp-mode abs-mode)))))
(fn pdat-processor.raw.size [raw] (length raw.bytes))
(fn pdat-processor.op.size [op] (size op.mode))
(fn pdat-processor.var.size [d] d.size)
(fn pdat-processor.ref.size [r] 2)
(fn pdat-processor.pad.size [pad]
(let [misalignment (% pad.addr pad.align)]
(if (= misalignment 0) 0
(- pad.align misalignment))))
(fn pdat-processor.op.bytes [op env]
(local bytegen (. opcodes op.opcode))
; (pp op)
(if bytegen
(let [opbyte (bytegen op.mode)
argbytes
(if
(and (= op.mode :imm) (= (type op.arg) "function"))
(int8-to-bytes (op.arg env))
(= op.mode :imm) (int8-to-bytes op.arg)
(= op.mode :rel)
(int8-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 2)))
(= (size op.mode) 2) (int8-to-bytes (env:lookup-addr op.arg))
(= (size op.mode) 3) (int16-to-bytes (env:lookup-addr op.arg))
"")]
(if opbyte
(.. (int8-to-bytes opbyte) argbytes)
(error (.. op.opcode " doesn't support mode " op.mode))))
""))
(fn pdat-processor.var.bytes [d env]
(local init (match (type d.init)
:number d.init
@ -236,11 +136,14 @@
(match d.size
1 (int8-to-bytes init)
2 (int16-to-bytes init)
3 (int24-to-bytes init)
4 (int32-to-bytes init)
n (string.rep "\0" n)))
(fn pdat-processor.ref.bytes [ref env]
(int16-to-bytes (env:lookup-addr ref.target)))
(fn pdat-processor.pad.bytes [pad] (string.rep "\0" pad.size))
(fn pdat-processor.meta.generate [{: f : addr} env] (f addr env))
(fn pdat-processor.block.symbols [block]
(lume.concat (lume.keys block.symbols) (lume.keys block.globals)))
@ -297,7 +200,8 @@
(var block (. self.org-to-block org))
(when (not block)
(set block (new-block))
(tset self.org-to-block org block))
(tset self.org-to-block org block)
(set block.org org))
{: block
: org
:prg self
@ -305,14 +209,8 @@
:append (fn [self ...] (self.prg:dbg self.org ...) (parse-dats self.block [...]) self)})
:parse-addr
(fn [self name]
(local addr (tonumber name))
(local addr ((or addr-parser tonumber) name))
(if addr addr (error (.. "Symbol '" name "' not found"))))
:is-zp?
(fn [self name]
(local org (. self.symbol-to-org name))
(if org (< org 0x100)
self.prg-base (self.prg-base:is-zp? name)
(< (self:parse-addr name) 0x100)))
:env-lookup
(fn [self name lookup ...]
(local org (. self.symbol-to-org name))
@ -324,6 +222,9 @@
(fn [self name]
; (print "looking up" name "in" self)
(or (self:env-lookup name :lookup-addr) (self:parse-addr name)))
:lookup-org
(fn [self name]
(or (self:env-lookup name :lookup-org) (self:parse-addr name)))
:pass
(fn [self passname]
(print passname)
@ -349,15 +250,16 @@
(set self.dbgfile nil))
self)
:read-hotswap
(fn [self machine]
(fn [self machine prg-new]
(let [addr-to-label {}
addr-to-size {}]
(each [_ block (pairs self.org-to-block)]
(each [label pdat (pairs block.preserved)]
(tset addr-to-label pdat.addr label)
(tset addr-to-size pdat.addr pdat.size)))
(collect [addr bytes (pairs (machine:read-batch addr-to-size))]
(values (. addr-to-label addr) bytes))))
(lume.merge (collect [addr bytes (pairs (machine:read-batch addr-to-size))]
(values (. addr-to-label addr) bytes))
(if (?. self.source :read-hotswap) (self.source:read-hotswap machine prg-new) {}))))
:write-hotswap
(fn [self machine hotswap]
(machine:write-batch

249
asm/z80.fnl Normal file
View file

@ -0,0 +1,249 @@
(local {: int8-to-bytes : int16-to-bytes} (require :lib.util))
(local lume (require :lib.lume))
(local fennel (require :lib.fennel))
(local opcodes {})
; http://www.z80.info/decoding.htm
(fn argmatch [matcher arg]
(case (type matcher)
:function (matcher arg)
:table (when (= (type arg) :table)
(accumulate [result {} i child (ipairs matcher) &until (= result nil)]
(case (argmatch child (. arg i))
argresult (lume.extend result argresult))))
_ (when (= matcher arg) {})))
(fn comp-matchers [m1 m2] (fn [arg] (or (argmatch m1 arg) (argmatch m2 arg))))
(fn rekey [matcher k knew]
(fn [arg] (match (matcher arg) {k val} {knew val})))
(fn try-parse-op [op matchers prefixgen]
(when (= (length matchers) (- (length op) 1))
(let [params
(accumulate [result {} i matcher (ipairs matchers) &until (= result nil)]
(let [arg (. op (+ i 1))
argresult (argmatch matcher arg)]
(when (not= argresult nil)
(lume.extend result argresult))))]
(when (not= params nil)
(case (prefixgen params)
prefix (lume.extend {: prefix} params))))))
(fn chain-op [opcode f]
(let [prev (or (. opcodes opcode) #nil)]
(tset opcodes opcode
(fn [op] (case (prev op)
result result
nil (f op))))))
(fn opform [opcode matchers prefixgen]
(chain-op opcode #(try-parse-op $1 matchers prefixgen)))
(fn table-matcher [tbl key]
(let [lookup (collect [i val (ipairs tbl)] val (- i 1))]
(fn [param] (case (. lookup param) octet {key octet}))))
(local cc (table-matcher [:nz :z :nc :c :po :pe :p :m] :cc))
(local reg (comp-matchers (table-matcher [:b :c :d :e :h :l :*hl :a] :reg)
#(when (argmatch [:hl] $1) {:reg 6})))
(local rp (table-matcher [:bc :de :hl :sp] :rp))
(local rp2 (table-matcher [:bc :de :hl :af] :rp))
(fn is-addr? [param] (and (= (type param) :string)
(not= param :ix) (not= param :iy)
(= (reg param) nil) (= (rp param) nil) (= (rp2 param) nil)))
(fn is-computed? [param] (= (type param) :function))
(fn is-number? [param] (= (type param) :number))
(fn rel-addr [param] (when (is-addr? param) {:rel8 param}))
(fn num [param] (when (or (is-number? param) (is-computed? param)) {:num param}))
(fn imm16 [param] (when (or (is-number? param) (is-computed? param) (is-addr? param)) {:imm16 param}))
(fn imm8 [param] (when (or (is-number? param) (is-computed? param)) {:imm8 param}))
(local addr imm16)
(fn im [arg] (match arg
0 {:im 0}
1 {:im 2}
2 {:im 3}
_ nil))
(fn ix [arg]
(case arg
:ix {:ixprefix "\xdd"}
:iy {:ixprefix "\xfd"}))
(fn def-alu [f]
(each [i opcode (ipairs [:add :adc :sub :sbc :and :xor :or :cp])]
(f opcode (- i 1))))
(fn def-rot [f]
(each [i opcode (ipairs [:rlc :rrc :rl :rr :sla :sra :sll :srl])]
(f opcode (- i 1))))
(fn xyz [x y z] (int8-to-bytes (bit.bor (bit.lshift x 6) (bit.lshift y 3) z)))
(fn xpqz [x p q z] (int8-to-bytes (bit.bor (bit.lshift x 6) (bit.lshift p 4) (bit.lshift q 3) z)))
(opform :nop [] #(xyz 0 0 0))
(opform :ex [:af :af_] #(xyz 0 1 0))
(opform :djnz [rel-addr] #(xyz 0 2 0))
(opform :jr [rel-addr] #(xyz 0 3 0))
(opform :jr [cc rel-addr] #(when (< $1.cc 4) (xyz 0 (+ $1.cc 4) 0)))
(opform :ld [rp imm16] #(xpqz 0 $1.rp 0 1))
(opform :add [:hl rp] #(xpqz 0 $1.rp 1 1))
(opform :ld [[:bc] :a] #(xpqz 0 0 0 2))
(opform :ld [[:de] :a] #(xpqz 0 1 0 2))
(opform :ld [[addr] :hl] #(xpqz 0 2 0 2))
(opform :ld [[addr] :a] #(xpqz 0 3 0 2))
(opform :ld [:a [:bc]] #(xpqz 0 0 1 2))
(opform :ld [:a [:de]] #(xpqz 0 1 1 2))
(opform :ld [:hl [addr]] #(xpqz 0 2 1 2))
(opform :ld [:a [addr]] #(xpqz 0 3 1 2))
(opform :inc [rp] #(xpqz 0 $1.rp 0 3))
(opform :dec [rp] #(xpqz 0 $1.rp 1 3))
(opform :inc [reg] #(xyz 0 $1.reg 4))
(opform :dec [reg] #(xyz 0 $1.reg 5))
(opform :ld [reg imm8] #(xyz 0 $1.reg 6))
(opform :rlca [] #(xyz 0 0 7))
(opform :rrca [] #(xyz 1 0 7))
(opform :rla [] #(xyz 2 0 7))
(opform :rra [] #(xyz 3 0 7))
(opform :daa [] #(xyz 4 0 7))
(opform :cpl [] #(xyz 5 0 7))
(opform :scf [] #(xyz 6 0 7))
(opform :ccf [] #(xyz 7 0 7))
(opform :ld [reg (rekey reg :reg :reg2)] #(when (or (not= $1.reg 6) (not= $1.reg 6))
(xyz 1 $1.reg $1.reg2)))
(opform :halt [] #(xyz 1 6 6))
(def-alu (fn [opcode alu] (opform opcode [reg] #(xyz 2 alu $1.reg))))
(opform :ret [cc] #(xyz 3 $1.cc 0))
(opform :pop [rp2] #(xpqz 3 $1.rp 0 1))
(opform :ret [] #(xpqz 3 0 1 1))
(opform :jp [:hl] #(xpqz 3 1 1 1))
(opform :exx [] #(xpqz 3 2 1 1))
(opform :ld [:sp :hl] #(xpqz 3 3 1 1))
(opform :jp [cc addr] #(xyz 3 $1.cc 2))
(opform :jp [addr] #(xyz 3 0 3))
(opform :out [[imm8] :a] #(xyz 3 2 3))
(opform :in [:a [imm8]] #(xyz 3 3 3))
(opform :ex [[:sp] :hl] #(xyz 3 4 3))
(opform :ex [:de :hl] #(xyz 3 5 3))
(opform :di [] #(xyz 3 6 3))
(opform :ei [] #(xyz 3 7 3))
(opform :call [cc addr] #(xyz 3 $1.cc 4))
(opform :push [rp2] #(xpqz 3 $1.rp 0 5))
(opform :call [addr] #(xpqz 3 0 1 5))
(def-alu (fn [opcode alu] (opform opcode [imm8] #(xyz 3 alu 6))))
(opform :rst [num] #(xyz 3 (/ $1.num 8) 7))
; DD / FD prefix
(each [opcode prev (pairs opcodes)]
(tset opcodes opcode
(fn [op]
(case op
[:ex :de :ix] (error "EX DI, IX does not exist")
[:ex :de :iy] (error "EX DI, IY does not exist"))
(var prefix nil)
(var rel8 nil)
(fn rewrite [new-prefix new-val ?rel8]
(if (= prefix nil) (set prefix new-prefix)
(not= prefix new-prefix) (error "Can't mix IX and IY in one op"))
(if (and ?rel8 rel8) (error "Only one displacement is allowed")
?rel8 (set rel8 ?rel8))
new-val)
(let [op-new (icollect [_ arg (ipairs op)]
(case arg
:ix (rewrite "\xdd" :hl)
:iy (rewrite "\xfd" :hl)
:ixl (rewrite "\xdd" :l)
:iyl (rewrite "\xfd" :l)
:ixh (rewrite "\xdd" :h)
:iyh (rewrite "\xfd" :h)
[:ix rel8] (rewrite "\xdd" [:hl] rel8)
[:iy rel8] (rewrite "\xfd" [:hl] rel8)
_ arg))
result (prev op-new)]
(if (= prefix nil) result
(= result nil) nil
(lume.extend result {: rel8 :prefix (.. prefix result.prefix)}))))))
; CB prefix
(def-rot (fn [opcode rot] (opform opcode [reg] #(.. "\xcb" (xyz 0 rot $1.reg)))))
(opform :bit [num reg] #(.. "\xcb" (xyz 1 $1.num $1.reg)))
(opform :res [num reg] #(.. "\xcb" (xyz 2 $1.num $1.reg)))
(opform :set [num reg] #(.. "\xcb" (xyz 3 $1.num $1.reg)))
; ED prefix
(opform :in [reg [:c]] #(when (not= $1.reg 6) (.. "\xed" (xyz 1 $1.reg 0))))
(opform :in [[:c]] #(.. "\xed" (xyz 1 6 0)))
(opform :out [[:c] reg] #(when (not= $1.reg 6) (.. "\xed" (xyz 1 $1.reg 1))))
(opform :out [[:c]] #(.. "\xed" (xyz 1 6 1)))
(opform :sbc [:hl rp] #(.. "\xed" (xpqz 1 $1.rp 0 2)))
(opform :adc [:hl rp] #(.. "\xed" (xpqz 1 $1.rp 1 2)))
(opform :ld [[addr] rp] #(.. "\xed" (xpqz 1 $1.rp 0 3)))
(opform :ld [rp [addr]] #(.. "\xed" (xpqz 1 $1.rp 1 3)))
(opform :neg [] #(.. "\xed" (xyz 1 0 4)))
(opform :retn [] #(.. "\xed" (xyz 1 0 5)))
(opform :reti [] #(.. "\xed" (xyz 1 1 5)))
(opform :im [im] #(.. "\xed" (xyz 1 $1.im 6)))
(opform :ld [:i :a] #(.. "\xed" (xyz 1 0 7)))
(opform :ld [:r :a] #(.. "\xed" (xyz 1 1 7)))
(opform :ld [:a :i] #(.. "\xed" (xyz 1 2 7)))
(opform :ld [:a :r] #(.. "\xed" (xyz 1 3 7)))
(opform :rrd [] #(.. "\xed" (xyz 1 4 7)))
(opform :rld [] #(.. "\xed" (xyz 1 5 7)))
(opform :ldi [] #(.. "\xed" (xyz 2 4 0)))
(opform :cpi [] #(.. "\xed" (xyz 2 4 1)))
(opform :ini [] #(.. "\xed" (xyz 2 4 2)))
(opform :outi [] #(.. "\xed" (xyz 2 4 3)))
(opform :ldd [] #(.. "\xed" (xyz 2 5 0)))
(opform :cpd [] #(.. "\xed" (xyz 2 5 1)))
(opform :ind [] #(.. "\xed" (xyz 2 5 2)))
(opform :outd [] #(.. "\xed" (xyz 2 5 3)))
(opform :ldir [] #(.. "\xed" (xyz 2 6 0)))
(opform :cpir [] #(.. "\xed" (xyz 2 6 1)))
(opform :inir [] #(.. "\xed" (xyz 2 6 2)))
(opform :otir [] #(.. "\xed" (xyz 2 6 3)))
(opform :lddr [] #(.. "\xed" (xyz 2 7 0)))
(opform :cpdr [] #(.. "\xed" (xyz 2 7 1)))
(opform :indr [] #(.. "\xed" (xyz 2 7 2)))
(opform :otdr [] #(.. "\xed" (xyz 2 7 3)))
; DDCB / FDCB prefix
(def-rot (fn [opcode rot]
(opform :ld [reg opcode [ix rel-addr]]
#(when (not= $1.reg 6) (.. $1.ixprefix "\xcb" (xyz 0 rot $1.reg))))
(opform opcode [[ix rel-addr]] #(.. $1.ixprefix "\xcb" (xyz 0 rot 6)))))
(opform :bit [num [ix rel-addr]] #(.. $1.ixprefix "\xcb" (xyz 1 $1.num 0)))
(opform :ld [reg :res num [ix rel-addr]]
#(when (not= $1.reg 6) (.. $1.ixprefix "\xcb" (xyz 2 $1.num $1.reg))))
(opform :res [num [ix rel-addr]] #(.. $1.ixprefix "\xcb" (xyz 2 $1.num 6)))
(opform :ld [reg :set num [ix rel-addr]]
#(when (not= $1.reg 6) (.. $1.ixprefix "\xcb" (xyz 3 $1.num $1.reg))))
(opform :set [num [ix rel-addr]] #(.. $1.ixprefix "\xcb" (xyz 3 $1.num 6)))
(fn parse-op [[opcode &as op]]
(let [result ((. opcodes opcode) op)]
(if (= result nil) (error (.. "no such opcode " (fennel.view op)))
result)))
(local op-pdat {})
(fn op-pdat.size [op env]
(+ (length op.prefix)
(case op
{: rel8} 1
{: imm16} 2
{: imm8} 1
_ 0)))
(fn decode-number [param env]
(case (type param)
:number param
:string (env:lookup-addr param)
:function (param (setmetatable {} {:__index #(env:lookup-addr $2)}) env)))
(fn op-pdat.bytes [op env]
(.. op.prefix
(case op
{: rel8} (int8-to-bytes (- (env:lookup-addr rel8) (+ op.addr 2)))
{: imm16} (int16-to-bytes (decode-number imm16 env))
{: imm8} (int8-to-bytes (decode-number imm8 env))
_ "")))
{: opcodes : parse-op : op-pdat : try-parse-op}

View file

@ -1,41 +1,40 @@
(local util (require :lib.util))
(local actions (require :editor.actions))
(local {: textbox : dropdown : textfield} (util.require :editor.imstate))
(local {: textbox : dropdown : textfield : label : under : right-of : reform : group-wrapper} (util.require :editor.imgui))
(local files (require :game.files))
(local lume (require :lib.lume))
(local style (require :core.style))
(actions.register :say
(fn [action view x y w i]
(let [characters (lume.map files.game.portraits #$1.label)
(fn [action form i]
(let [characters (lume.map (or files.game.portraits []) #$1.label)
character (or action.character (. characters 1))
lines (or action.lines [])
(character y) (dropdown view [:say :char i] character characters x (+ y style.padding.y) w)
(line1 y) (textbox view [:say :line1 i] (or (. lines 1) "") x (+ y style.padding.y) w)
(line2 y) (textbox view [:say :line2 i] (or (. lines 2) "") x y w)
(line3 y) (textbox view [:say :line3 i] (or (. lines 3) "") x y w)
(line4 y) (textbox view [:say :line4 i] (or (. lines 4) "") x y w)]
character (dropdown (under form {:tag [:say :char i] :w form.w}) character characters)
line1 (textbox (under form {:tag [:say :line1 i] :w form.w}) (or (. lines 1) ""))
line2 (textbox (under form {:tag [:say :line2 i] :w form.w}) (or (. lines 2) ""))
line3 (textbox (under form {:tag [:say :line3 i] :w form.w}) (or (. lines 3) ""))
line4 (textbox (under form {:tag [:say :line4 i] :w form.w}) (or (. lines 4) ""))]
(set action.character character)
(util.nested-tset action [:lines 1] (line1:sub 1 33))
(util.nested-tset action [:lines 2] (line2:sub 1 33))
(util.nested-tset action [:lines 3] (line3:sub 1 33))
(util.nested-tset action [:lines 4] (line4:sub 1 33))
y))
(util.nested-tset action [:lines 4] (line4:sub 1 33))))
(fn [action vm]
(local {: say} (require :bitsy.defs))
(say action.character (table.unpack (lume.map action.lines #($1:upper))))))
(actions.register :warp
(fn [action view x y w i]
(let [maps (icollect [imap _ (ipairs files.game.levels)] (.. :map imap))
(fn [action form i]
(let [g (group-wrapper form)
maps (icollect [imap _ (ipairs files.game.levels)] (.. :map imap))
map (or action.map (. maps 1))
y (+ y style.padding.y)
map (dropdown view [:warp :map i] map maps x y (* 100 SCALE))
(position-string y) (textbox view [:warp :loc i] (string.format "%x" (or action.position 0)) (+ x (* 150 SCALE)) y (* 150 SCALE))
map (g dropdown (under form {:tag [:warp :map i] :w (- (/ form.w 2) form.xpad)}) map maps)
position-string (g textbox (right-of form {:tag [:warp :loc i] :w form.w}) (string.format "%x" (or action.position 0)))
position (or (tonumber position-string 16) action.position)]
(set action.map map)
(set action.position position)
y))
(g)))
(fn [action vm]
(values :move-to-responder action.position :lit action.map :map-player-yx-ptr :set :lit action.map :next-level :set)))
@ -43,20 +42,17 @@
(actions.register-const :disappear :disappear)
(actions.register :set-flag
(fn [action view x y w i]
(let [y (+ y style.padding.y)
x (renderer.draw_text style.font "Set " x y style.text)
flag (or action.flag (. files.game.flags 1))
flag (dropdown view [:set-flag :flag i] flag files.game.flags x y (* 100 SCALE))
x (renderer.draw_text style.font " to " (+ x (* 100 SCALE)) y style.text)
(fn [action form i]
(let [g (group-wrapper form)
options (lume.concat
[{:label "<Yes>" :value 0xffff} {:label "<No>" :value 0}]
(icollect [_ flag (ipairs files.game.flags)] {:label flag :value (.. :cond- flag)}))
rhs (or action.rhs (. options 1))
(rhs y) (dropdown view [:set-flag :rhs i] rhs options x y (* 100 SCALE))]
(set action.flag flag)
(set action.rhs rhs)
y))
rhs (or action.rhs (. options 1))]
(g label (reform form) "Set ")
(set action.flag (g dropdown (right-of form {:tag [:set-flag :flag i] :w (* 100 SCALE)}) action.flag files.game.flags))
(g label (right-of form) " to ")
(set action.rhs (g dropdown (right-of form {:tag [:set-flag :rhs i] :w (* 100 SCALE)}) rhs options))
(g)))
(fn [action vm]
(values action.rhs.value (.. :cond-var- action.flag) :set)))

View file

@ -1,13 +1,12 @@
(local util (require :lib.util))
(local {: defmulti : defmethod} (util.require :lib.multimethod))
(local {: textfield} (util.require :editor.imstate))
(local actions (util.hot-table ...))
(set actions.edit (defmulti #$1.action :edit ...))
(set actions.generate (defmulti #$1.action :generate ...))
(defmethod actions.edit :default (fn [action view x y w i] y))
(defmethod actions.edit :default (fn [action form i]))
(fn actions.register [key edit generate]
(when (= actions.actionlist nil)
@ -18,6 +17,6 @@
(defmethod actions.generate key generate))
(fn actions.register-const [key generated-value]
(actions.register key (fn [action view x y w i] y) #generated-value))
(actions.register key (fn [action form i]) #generated-value))
actions.hot

View file

@ -2,18 +2,18 @@
(local tiledraw (require :editor.tiledraw))
(local tiles (require :game.tiles))
(local style (require :core.style))
(local files (require :game.files))
(local FontEditView (TileView:extend))
(fn FontEditView.tilesize [self] (values 8 8))
(fn FontEditView.tilekeys [self] [:gfx])
(fn FontEditView.map-bitxy [self x y] (values y x))
(fn FontEditView.draw-tile-flags [self x y]
(fn FontEditView.draw-sidebar [self {: x : y}]
(when self.itile
(local char (string.char (+ self.itile 0x20 -1)))
(renderer.draw_text style.big_font char x y style.text))
(love.graphics.setColor 1 1 1 1))
(fn FontEditView.resource-key [self] :font)
(fn FontEditView.initial-style [self] :font)
(fn FontEditView.get_name [self] "Font Editor")
FontEditView

View file

@ -3,7 +3,7 @@
(local tiledraw (require :editor.tiledraw))
(local util (require :lib.util))
(local files (require :game.files))
(local {: attach-imstate : mouse-inside : activate : active? : button} (util.require :editor.imstate))
(local {: attach-imstate : button : reform : horiz-wrapper : group-wrapper} (util.require :editor.imgui))
(local GraphicsEditView (View:extend))
@ -12,15 +12,19 @@
(fn GraphicsEditView.new [self]
(GraphicsEditView.super.new self)
(set self.tilecache (files.cache (self:resource-key)))
(set self.itile 1)
(self:set-style (self:initial-style))
(set self.scrollheight math.huge)
(set self.scrollable true)
(attach-imstate self))
(fn GraphicsEditView.get_scrollable_size [self] self.scrollheight)
(fn GraphicsEditView.resource-key [self] :tiles)
(fn GraphicsEditView.tilesize [self] (values 16 16))
(fn GraphicsEditView.tilebytelen [self] (let [(w h) (self:tilesize)] (/ (* w h) 8)))
(fn GraphicsEditView.initial-style [self] :tiles)
(fn GraphicsEditView.tilesize [self]
(let [style (tiles.style self.style)]
(values (or style.editw style.tilew) (or style.edith style.tileh))))
(fn GraphicsEditView.set-style [self key]
(set self.style key)
(set self.tilecache (files.cache key))
(set self.itile 1))
(fn GraphicsEditView.reload [self] (files.reload))
(fn GraphicsEditView.save [self] (files.save))
@ -30,26 +34,31 @@
(when (>= itile 1) (set self.itile itile))))
(fn GraphicsEditView.draw-sprite [self x y itile ?key]
(love.graphics.draw (self.tilecache:sprite itile ?key) x y 0 self.sprite-scale self.sprite-scale))
(let [sprite (self.tilecache:sprite itile ?key)]
(when sprite
(love.graphics.setColor 1 1 1)
(love.graphics.draw sprite x y 0 self.sprite-scale self.sprite-scale)
(values (* (sprite:getWidth) self.sprite-scale) (* (sprite:getHeight) self.sprite-scale)))))
(fn GraphicsEditView.draw-tile-selector [self x y w ?key]
(var tilex x)
(var tiley y)
(var (pixw pixh) (self:tilesize))
(set pixw (* (/ pixw 8) 7))
(local tilew (* self.sprite-scale pixw))
(local tileh (* self.sprite-scale pixh))
(for [itile 1 (length self.tilecache.tiles)]
(self:draw-sprite tilex tiley itile ?key)
(when (and (= itile self.itile) (= ?key self.tilekey))
(love.graphics.rectangle :line (- tilex 2) (- tiley 2) (+ tilew 4) (+ tileh 4)))
(when (button self [:tile itile] tilex tiley tilew tileh)
(set self.itile itile)
(set self.tilekey ?key))
(set tilex (+ tilex tilew 4))
(when (>= (+ tilex tilew) (+ x w))
(set tilex x)
(set tiley (+ tiley tileh 4))))
(+ tiley tileh (- y)))
(fn tile-selector [{: view &as form} selected-itile ?key]
(var selected-itile selected-itile)
(let [g (group-wrapper form)
wrap (horiz-wrapper form)]
(for [itile 1 (length view.tilecache.tiles)]
(let [{: x : y} form
(w h) (view:draw-sprite x y itile ?key)]
(when (and w h)
(when (= itile selected-itile)
(love.graphics.rectangle :line (- x 2) (- y 2) (+ w 4) (+ h 4)))
(when (g button (reform form {:tag [:tile itile] : w : h}))
(set selected-itile itile))
(wrap form))))
(g)
selected-itile))
(fn GraphicsEditView.draw-tile-selector [self form ?key]
(match (tile-selector (reform form {:scale self.sprite-scale :w form.w}) (when (= self.tilekey ?key) self.itile) ?key)
selected-itile (do (set self.itile selected-itile)
(set self.tilekey ?key))))
GraphicsEditView

389
editor/imgui.fnl Normal file
View file

@ -0,0 +1,389 @@
(local core (require :core))
(local config (require :core.config))
(local command (require :core.command))
(local keymap (require :core.keymap))
(local style (require :core.style))
(local lume (require :lib.lume))
(fn attach-imstate [view]
(set view.imstate {})
(fn view.on_mouse_pressed [self button x y clicks]
(tset self.imstate button :pressed)
(self.__index.on_mouse_pressed self button x y clicks))
(fn view.on_mouse_released [self button x y]
(tset self.imstate button :released)
(self.__index.on_mouse_released self button x y))
(fn view.on_key_pressed [self key]
(when (= self.imstate.keys nil)
(set self.imstate.keys []))
(table.insert self.imstate.keys key))
(fn view.on_text_input [self text]
(set self.imstate.text (.. (or self.imstate.text "") text))
(self.__index.on_text_input self text))
(fn view.form [self ?overrides]
(lume.merge {:x (+ self.position.x style.padding.x (- self.scroll.x))
:y (+ self.position.y style.padding.y (- self.scroll.y))
:w (- self.size.x (* style.padding.x 2))
:view self}
(or ?overrides {})))
(fn view.end-scroll [self {: y : h}]
(let [pin-to-bottom (>= self.scroll.to.y (- self.scrollheight self.size.y))]
(set self.scrollheight (- (+ y (or h 0) style.padding.y) (+ self.position.y style.padding.y (- self.scroll.y))))
(when pin-to-bottom (set self.scroll.to.y (- self.scrollheight self.size.y)))))
(fn view.draw [self]
(set self.cursor nil)
(self.__index.draw self)
(when self.imstate.postponed
(each [_ action (ipairs self.imstate.postponed)]
(action))
(set self.imstate.postponed nil))
(when (= self.cursor nil) (set self.cursor :arrow))
(set self.imstate.keys nil)
(set self.imstate.text nil)
(when (= self.imstate.left :released)
(set self.imstate.active nil))
(each [_ button (pairs [:left :middle :right])]
(tset self.imstate button
(match (. self.imstate button)
:pressed :down
:down :down
:released nil)))))
(fn register-keys [keys]
(local commands {})
(local keymaps {})
(each [_ key (ipairs keys)]
(local command-name (.. "imstate:" key))
(tset commands command-name #(core.active_view:on_key_pressed key))
(tset keymaps key command-name))
(command.add #(not= (-?> core.active_view.imstate (. :focus)) nil) commands)
(keymap.add keymaps))
(register-keys [:backspace :delete :left :right :shift+left :shift+right :home :end :shift+home :shift+end
:ctrl+left :ctrl+right :ctrl+shift+left :ctrl+shift+right :ctrl+c :ctrl+v])
(fn cmd-predicate [p]
(var p-fn p)
(when (= (type p-fn) :string) (set p-fn (require p-fn)))
(when (= (type p-fn) :table)
(local cls p-fn)
(set p-fn (fn [] (core.active_view:is cls))))
(fn [] (when (= (-?> core.active_view.imstate (. :focus)) nil)
(p-fn))))
(fn postpone [view f]
(when (= view.imstate.postponed nil)
(set view.imstate.postponed []))
(table.insert view.imstate.postponed f))
(fn make-tag [tag]
(match (type tag)
:string tag
:table (table.concat tag "::")
_ (tostring tag)))
(fn mouse-inside [x y w h]
(local (mx my) (values (love.mouse.getX) (love.mouse.getY)))
(and (>= mx x) (<= mx (+ x w)) (>= my y) (<= my (+ y h))))
(fn consume-pressed [view button]
(when (= (. view.imstate button) :pressed)
(tset view.imstate button :down)
true))
(fn activate [{: view : tag : x : y : w : h}]
(when (and (mouse-inside x y w h) (consume-pressed view :left))
(set view.imstate.active (make-tag tag))
true))
(fn set-cursor [view cursor]
(when (= view.cursor nil) (set view.cursor cursor)))
;; styling and layout
(fn form-defaults [form k v ...]
(when (= (. form k) nil)
(let [v (if (= (type v) :function) (v form) v)]
(tset form k v)))
(if (>= (select :# ...) 2) (form-defaults form ...)
(do (when form.tag (set form.tag (make-tag form.tag))) ; fix up tag
form)))
(fn with-style [form ...]
(form-defaults form :font style.font :color style.text :xpad style.padding.x :ypad style.padding.y ...))
(local form-preserved-keys (collect [_ key (ipairs [:view :x :y :font :color :xpad :ypad])] key true))
(fn reform [form overrides]
(if (and overrides overrides.into (not= overrides.into form))
(reform (lume.extend (lume.clear overrides.into) form) overrides)
(do (each [key (pairs form)]
(when (= (. form-preserved-keys key) nil)
(tset form key nil)))
(lume.extend form (or overrides {})))))
(fn under [form overrides] (reform form (lume.merge (or overrides {}) {:y (+ form.y (or form.h 0) (or form.ypad 0))})))
(fn right-of [form overrides] (reform form (lume.merge (or overrides {}) {:x (+ form.x (or form.w 0) (or form.xpad 0))})))
(fn group-wrapper [orig-form]
(let [group {}
update-dimension
(fn [form coord-key size-key]
(let [coord-group (. group coord-key) size-group (. group size-key)
coord-form (. form coord-key) size-form (. form size-key)]
(if (= size-form nil) ; tried to add an unsized value to the group, ignore
nil
(= coord-group nil) ; container takes on the size of its first item
(do (tset group coord-key coord-form)
(tset group size-key size-form))
(> coord-group coord-form) ; we have an item that is outside the bounds to the left / up; reduce the starting point and extend the size
(do (tset group coord-key coord-form)
(tset group size-key (- (math.max (+ coord-form size-form) (+ coord-group size-group)) coord-form)))
; extend the size if the new item is outside the bounds to the right / down
(tset group size-key (- (math.max (+ coord-form size-form) (+ coord-group size-group)) coord-group)))
form))
update-dimensions (fn [form] (update-dimension form :x :w) (update-dimension form :y :h))]
(fn [?viewfn-or-form ?form ...]
(match [(type ?viewfn-or-form) ?viewfn-or-form]
[:function viewfn] (let [result [(viewfn ?form ...)]]
(update-dimensions ?form)
(table.unpack result))
[:table form] (update-dimensions form)
[:nil] (lume.extend orig-form group)))))
(fn horiz-wrapper [{:x orig-x :w orig-w}]
(fn [{: x : y : w : h : xpad : ypad &as form} overrides]
(if (> (+ x (or w 0) xpad (or w 0)) (+ orig-x orig-w))
(reform form (lume.merge (or overrides {}) {:x orig-x :y (+ y (or h 0) (or ypad 0))}))
(right-of form overrides))))
;; widgets and widget helpers
(fn active? [view tag] (= view.imstate.active (make-tag tag)))
(fn button [{: view : tag : x : y : w : h &as form}]
(when (mouse-inside x y w h) (set-cursor view :hand))
(activate form)
(and (active? view tag) (= view.imstate.left :released) (mouse-inside x y w h)))
(fn label [form text]
(let [(_ newlines) (text:gsub "\n" "\n")
text-height (fn [font] (* (font:get_height) (+ newlines 1)))
{: x : y : w : h : halign : valign : font : color}
(with-style form
:w #($1.font:get_width text)
:h #(text-height $1.font)
:halign :left
:valign :center)
x (match halign :left x :center (+ x (/ (- w (font:get_width text)) 2)) :right (+ x w (- (font:get_width text))))
y (match valign :top y :center (+ y (/ (- h (text-height font)) 2)) :bottom (+ y h (- (text-height font))))]
(renderer.draw_text font text x y color)))
(fn textbutton [form label]
(let [{: x : y : w : h : xpad : ypad : font : color : bg}
(with-style form
:bg style.selection
:tag label
:w #(+ ($1.font:get_width label) $1.xpad)
:h #(+ ($1.font:get_height) $1.ypad))]
(renderer.draw_rect x y w h bg)
(renderer.draw_text font label (+ x (/ xpad 2)) (+ y (/ ypad 2)) color)
(button form)))
(fn checkbox [form name isset]
(let [{: x : y : w : h : font : color : x-label}
(with-style form
:tag name
:h (* 12 SCALE)
:x-label #(+ $1.x $1.h $1.xpad)
:w #(+ $1.x-label ($1.font:get_width name)))]
(love.graphics.rectangle (if isset :fill :line) x y h h)
(renderer.draw_text font name x-label y color)
(love.graphics.setColor 1 1 1 1)
(button form))) ; whose idea was this?? should return (not isset) >:/
(fn focused? [view tag] (= (make-tag tag) (-?> view.imstate.focus (. :tag))))
(fn focus [{: view : tag : x : y : w : h &as form} opts]
(if (activate form)
(set view.imstate.focus
(doto (lume.clone (or opts {}))
(tset :tag (make-tag tag))))
(and (= view.imstate.left :released) (focused? view tag) (not (mouse-inside x y w h)))
(set view.imstate.focus nil))
(focused? view tag))
(local blink_period 0.8)
(fn x-from-i [s i xLeft font]
(if (or (<= i 1) (= s "")) xLeft
(x-from-i (s:sub 2) (- i 1) (+ xLeft (font:get_width (s:sub 1 1))) font)))
(fn i-from-x [s x xLeft font ?i]
(local i (or ?i 1))
(local w (font:get_width (s:sub 1 1)))
(local xMid (+ xLeft (/ w 2)))
(if (or (<= x xMid) (= s "")) i
(i-from-x (s:sub 2) x (+ xLeft w) font (+ i 1))))
(fn next-match [text i di pred]
(local imax (+ (length text) 1))
(local inext (+ i di))
(if (<= inext 1) 1
(> inext imax) imax
(pred (text:sub inext inext)) (if (< di 0) i inext)
(next-match text inext di pred)))
(fn is-nonword-char [char] (config.non_word_chars:find char nil true))
(fn next-word [text i di]
(let [iwordboundary (next-match text i di #(is-nonword-char $1))]
(next-match text iwordboundary di #(not (is-nonword-char $1)))))
(fn textnav [key i text]
(local imax (+ (length text) 1))
(match key
:left (math.max 1 (- i 1))
:right (math.min imax (+ i 1))
:ctrl+left (next-word text i -1)
:ctrl+right (next-word text i 1)
:home 1
:end imax))
(fn selection-span [view]
(let [f view.imstate.focus
iStart (math.min f.i f.iAnchor)
iLim (math.max f.i f.iAnchor)]
(values iStart iLim)))
(fn selection-text [view text]
(local (iStart iLim) (selection-span view))
(text:sub iStart (- iLim 1)))
(fn replace-selection [view s replacement ?iStart ?iLim]
(local (iStart iLim) (if ?iLim (values ?iStart ?iLim) (selection-span view)))
(local text
(.. (s:sub 1 (- iStart 1))
replacement
(s:sub iLim)))
(local iNew (+ iStart (length replacement)))
(set view.imstate.focus.i iNew)
(set view.imstate.focus.iAnchor iNew)
text)
(fn textbox [form text]
(local {: font : color : w : h : x : y : xpad : ypad : color : view : tag}
(with-style form :h #(+ ($1.font:get_height) $1.ypad)))
(var textNew (or text ""))
(local (hText xText yText) (values (font:get_height) (+ x (/ xpad 2)) (+ y (/ ypad 2))))
(local initial-press (= view.imstate.left :pressed))
; handle key events
(when (focus form {:i 1 :iAnchor 1 :blink (love.timer.getTime)})
(local f view.imstate.focus)
(when (> f.i (+ (length textNew) 1)) (set f.i (+ (length textNew) 1)))
(when (> f.iAnchor (+ (length textNew) 1)) (set f.iAnchor (+ (length textNew) 1)))
(when view.imstate.text
(set textNew (replace-selection view textNew view.imstate.text)))
(each [_ key (ipairs (or view.imstate.keys []))]
(set view.imstate.focus.blink (love.timer.getTime))
(if (= key :ctrl+c) (system.set_clipboard (selection-text view textNew))
(= key :ctrl+v) (set textNew (replace-selection view textNew (system.get_clipboard)))
(key:find "shift%+") (set f.i (or (textnav (key:gsub "shift%+" "") f.i textNew) f.i))
(let [iNav (textnav key f.i textNew)]
(when iNav
(set f.i iNav)
(set f.iAnchor iNav))
(when (or (= key :delete) (= key :backspace))
(local (iStartDel iLimDel)
(if (not= f.i f.iAnchor) (selection-span view)
(= key :delete) (values f.i (+ f.i 1))
(= key :backspace) (values (math.max 1 (- f.i 1)) f.i)))
(set textNew (replace-selection view textNew "" iStartDel iLimDel)))))))
; handle mouse events
(when (mouse-inside x y w h) (set-cursor view :ibeam))
(when (and (focused? view tag) (active? view tag) (mouse-inside x y w h))
(local mouse-i (i-from-x textNew (love.mouse.getX) x style.font))
(when initial-press
(set view.imstate.focus.iAnchor mouse-i))
(set view.imstate.focus.i mouse-i))
; draw box
(love.graphics.setLineWidth 1)
(love.graphics.rectangle :line x y w h)
(if (focused? view tag)
; draw text with selection + caret
(let [(iStart iLim) (selection-span view)
xSelect (renderer.draw_text font (textNew:sub 1 (- iStart 1)) xText yText color)
sSelect (textNew:sub iStart (- iLim 1))
wSelect (font:get_width sSelect)
xTail (+ xSelect wSelect)]
(when (> wSelect 0)
(renderer.draw_rect xSelect yText wSelect hText style.selection)
(renderer.draw_text font sSelect xSelect yText color))
(renderer.draw_text font (textNew:sub iLim) xTail yText color)
(when (or (active? view tag)
(< (% (- (love.timer.getTime) view.imstate.focus.blink) (* blink_period 2)) blink_period))
(renderer.draw_rect (x-from-i textNew view.imstate.focus.i xText font) yText style.caret_width hText style.caret)))
; just draw the text
(renderer.draw_text font textNew xText yText color))
(love.graphics.setColor 1 1 1)
textNew)
(fn textfield [form label text]
(let [{: x : y : w : wlabel : wtext : font : color}
(with-style form :wlabel #(+ ($1.font:get_width label) $1.xpad)
:wtext (* 150 SCALE)
:w #(+ $1.wlabel $1.wtext)
:tag label)
form-textbox (lume.merge form {:w wtext :x (+ x wlabel)})
_ (renderer.draw_text font label x y color)
text (textbox form-textbox text)]
(set form.h form-textbox.h)
text))
(fn option-text [option]
(match (type option)
:string option
:table (or option.label (tostring option))
_ (tostring option)))
(fn dropdown [form selection options]
(let [{: x : y : w :h row-h : font : color : bg : xpad : ypad : view : tag}
(with-style form :w (* 150 SCALE)
:h #(+ ($1.font:get_height) $1.ypad)
:bg style.selection)]
(var new-selection nil)
(renderer.draw_rect x y w row-h bg)
(renderer.draw_text style.font (option-text selection) (+ x xpad) (+ y (/ ypad 2)) color)
(renderer.draw_text style.icon_font "-" (+ x w (- xpad)) (+ y (/ ypad 2)) color)
(when (focused? view tag)
(var row-y (+ y row-h))
(each [i option (ipairs options)]
(when (button (lume.merge form {:tag [(make-tag tag) i] :y row-y}))
(set new-selection option))
(set row-y (+ row-y row-h)))
(postpone view (fn []
(var row-y (+ y row-h))
(each [i option (ipairs options)]
(renderer.draw_rect x row-y w row-h bg)
(renderer.draw_text font (option-text option) (+ x xpad) (+ row-y (/ ypad 2)) color)
(set row-y (+ row-y row-h))))))
(focus form)
(or new-selection selection)))
(fn labelled-dropdown [form label selection options]
(let [{: x : y : wlabel : wdropdown : font : color}
(with-style form :wlabel #(+ ($1.font:get_width label) $1.xpad)
:wdropdown (* 150 SCALE)
:w #(+ $1.wlabel $1.wdropdown)
:tag label)
form-dropdown (lume.merge form {:x (+ x wlabel) :w wdropdown})
_ (renderer.draw_text font label x y color)
selection (dropdown form-dropdown selection options)]
(set form.h form-dropdown.h)
selection))
{: attach-imstate : cmd-predicate : postpone : mouse-inside : activate : active?
: button : checkbox : textbox : textfield : textbutton : dropdown : labelled-dropdown : label
: reform : under : right-of : horiz-wrapper : group-wrapper
: with-style : form-defaults}

View file

@ -1,267 +0,0 @@
(local core (require :core))
(local config (require :core.config))
(local command (require :core.command))
(local keymap (require :core.keymap))
(local style (require :core.style))
(local lume (require :lib.lume))
(fn attach-imstate [view]
(set view.imstate {})
(fn view.on_mouse_pressed [self button x y clicks]
(tset self.imstate button :pressed)
(self.__index.on_mouse_pressed self button x y clicks))
(fn view.on_mouse_released [self button x y]
(tset self.imstate button :released)
(self.__index.on_mouse_released self button x y))
(fn view.on_key_pressed [self key]
(when (= self.imstate.keys nil)
(set self.imstate.keys []))
(table.insert self.imstate.keys key))
(fn view.on_text_input [self text]
(set self.imstate.text (.. (or self.imstate.text "") text))
(self.__index.on_text_input self text))
(fn view.draw [self]
(set self.cursor nil)
(self.__index.draw self)
(when self.imstate.postponed
(each [_ action (ipairs self.imstate.postponed)]
(action))
(set self.imstate.postponed nil))
(when (= self.cursor nil) (set self.cursor :arrow))
(set self.imstate.keys nil)
(set self.imstate.text nil)
(when (= self.imstate.left :released)
(set self.imstate.active nil))
(each [_ button (pairs [:left :middle :right])]
(tset self.imstate button
(match (. self.imstate button)
:pressed :down
:down :down
:released nil)))))
(fn register-keys [keys]
(local commands {})
(local keymaps {})
(each [_ key (ipairs keys)]
(local command-name (.. "imstate:" key))
(tset commands command-name #(core.active_view:on_key_pressed key))
(tset keymaps key command-name))
(command.add #(not= (-?> core.active_view.imstate (. :focus)) nil) commands)
(keymap.add keymaps))
(register-keys [:backspace :delete :left :right :shift+left :shift+right :home :end :shift+home :shift+end
:ctrl+left :ctrl+right :ctrl+shift+left :ctrl+shift+right :ctrl+c :ctrl+v])
(fn cmd-predicate [p]
(var p-fn p)
(when (= (type p-fn) :string) (set p-fn (require p-fn)))
(when (= (type p-fn) :table)
(local cls p-fn)
(set p-fn (fn [] (core.active_view:is cls))))
(fn [] (when (= (-?> core.active_view.imstate (. :focus)) nil)
(p-fn))))
(fn postpone [view f]
(when (= view.imstate.postponed nil)
(set view.imstate.postponed []))
(table.insert view.imstate.postponed f))
(fn make-tag [tag]
(match (type tag)
:string tag
:table (table.concat tag "::")
_ (tostring tag)))
(fn mouse-inside [x y w h]
(local (mx my) (values (love.mouse.getX) (love.mouse.getY)))
(and (>= mx x) (<= mx (+ x w)) (>= my y) (<= my (+ y h))))
(fn consume-pressed [view button]
(when (= (. view.imstate button) :pressed)
(tset view.imstate button :down)
true))
(fn activate [view tag x y w h]
(when (and (mouse-inside x y w h) (consume-pressed view :left))
(set view.imstate.active (make-tag tag))
true))
(fn set-cursor [view cursor]
(when (= view.cursor nil) (set view.cursor cursor)))
(fn active? [view tag] (= view.imstate.active (make-tag tag)))
(fn button [view tag x y w h]
(when (mouse-inside x y w h) (set-cursor view :hand))
(activate view tag x y w h)
(values (and (active? view tag) (= view.imstate.left :released) (mouse-inside x y w h)) (+ y h style.padding.y)))
(fn textbutton [view label x y ?font]
(let [font (or ?font style.font)]
(local (w h) (values (+ (font:get_width label) style.padding.x) (+ (font:get_height) style.padding.y)))
(renderer.draw_rect x y w h style.selection)
(renderer.draw_text font label (+ x (/ style.padding.x 2)) (+ y (/ style.padding.y 2)) style.text)
(values (button view label x y w h) (+ y h))))
(fn checkbox [view name isset x y ?tag]
(love.graphics.rectangle (if isset :fill :line) x y (* 12 SCALE) (* 12 SCALE))
(local xEnd (renderer.draw_text style.font name (+ x (* 16 SCALE)) y style.text))
(love.graphics.setColor 1 1 1 1)
(button view (or ?tag name) x y (- xEnd x) (* 12 SCALE)))
(fn focused? [view tag] (= (make-tag tag) (-?> view.imstate.focus (. :tag))))
(fn focus [view tag x y w h opts]
(if (activate view tag x y w h)
(set view.imstate.focus
(doto (lume.clone (or opts {}))
(tset :tag (make-tag tag))))
(and (= view.imstate.left :released) (focused? view tag) (not (mouse-inside x y w h)))
(set view.imstate.focus nil))
(focused? view tag))
(local blink_period 0.8)
(fn x-from-i [s i xLeft font]
(if (or (<= i 1) (= s "")) xLeft
(x-from-i (s:sub 2) (- i 1) (+ xLeft (font:get_width (s:sub 1 1))) font)))
(fn i-from-x [s x xLeft font ?i]
(local i (or ?i 1))
(local w (font:get_width (s:sub 1 1)))
(local xMid (+ xLeft (/ w 2)))
(if (or (<= x xMid) (= s "")) i
(i-from-x (s:sub 2) x (+ xLeft w) font (+ i 1))))
(fn next-match [text i di pred]
(local imax (+ (length text) 1))
(local inext (+ i di))
(if (<= inext 1) 1
(> inext imax) imax
(pred (text:sub inext inext)) (if (< di 0) i inext)
(next-match text inext di pred)))
(fn is-nonword-char [char] (config.non_word_chars:find char nil true))
(fn next-word [text i di]
(let [iwordboundary (next-match text i di #(is-nonword-char $1))]
(next-match text iwordboundary di #(not (is-nonword-char $1)))))
(fn textnav [key i text]
(local imax (+ (length text) 1))
(match key
:left (math.max 1 (- i 1))
:right (math.min imax (+ i 1))
:ctrl+left (next-word text i -1)
:ctrl+right (next-word text i 1)
:home 1
:end imax))
(fn selection-span [view]
(let [f view.imstate.focus
iStart (math.min f.i f.iAnchor)
iLim (math.max f.i f.iAnchor)]
(values iStart iLim)))
(fn selection-text [view text]
(local (iStart iLim) (selection-span view))
(text:sub iStart (- iLim 1)))
(fn replace-selection [view s replacement ?iStart ?iLim]
(local (iStart iLim) (if ?iLim (values ?iStart ?iLim) (selection-span view)))
(local text
(.. (s:sub 1 (- iStart 1))
replacement
(s:sub iLim)))
(local iNew (+ iStart (length replacement)))
(set view.imstate.focus.i iNew)
(set view.imstate.focus.iAnchor iNew)
text)
(fn textbox [view tag text x y w]
(var textNew (or text ""))
(local (h hText xText yText) (values (+ (style.font:get_height) 4) (style.font:get_height) (+ x 2) (+ y 2)))
(local initial-press (= view.imstate.left :pressed))
; handle key events
(when (focus view tag x y w h {:i 1 :iAnchor 1 :blink (love.timer.getTime)})
(local f view.imstate.focus)
(when (> f.i (+ (length text) 1)) (set f.i (+ (length text) 1)))
(when (> f.iAnchor (+ (length text) 1)) (set f.iAnchor (+ (length text) 1)))
(when view.imstate.text
(set textNew (replace-selection view textNew view.imstate.text)))
(each [_ key (ipairs (or view.imstate.keys []))]
(set view.imstate.focus.blink (love.timer.getTime))
(if (= key :ctrl+c) (system.set_clipboard (selection-text view textNew))
(= key :ctrl+v) (set textNew (replace-selection view textNew (system.get_clipboard)))
(key:find "shift%+") (set f.i (or (textnav (key:gsub "shift%+" "") f.i textNew) f.i))
(let [iNav (textnav key f.i textNew)]
(when iNav
(set f.i iNav)
(set f.iAnchor iNav))
(when (or (= key :delete) (= key :backspace))
(local (iStartDel iLimDel)
(if (not= f.i f.iAnchor) (selection-span view)
(= key :delete) (values f.i (+ f.i 1))
(= key :backspace) (values (math.max 1 (- f.i 1)) f.i)))
(set textNew (replace-selection view textNew "" iStartDel iLimDel)))))))
; handle mouse events
(when (mouse-inside x y w h) (set-cursor view :ibeam))
(when (and (focused? view tag) (active? view tag) (mouse-inside x y w h))
(local mouse-i (i-from-x textNew (love.mouse.getX) x style.font))
(when initial-press
(set view.imstate.focus.iAnchor mouse-i))
(set view.imstate.focus.i mouse-i))
; draw box
(love.graphics.setLineWidth 1)
(love.graphics.rectangle :line x y w h)
(if (focused? view tag)
; draw text with selection + caret
(let [(iStart iLim) (selection-span view)
xSelect (renderer.draw_text style.font (textNew:sub 1 (- iStart 1)) xText yText style.text)
sSelect (textNew:sub iStart (- iLim 1))
wSelect (style.font:get_width sSelect)
xTail (+ xSelect wSelect)]
(when (> wSelect 0)
(renderer.draw_rect xSelect yText wSelect hText style.selection)
(renderer.draw_text style.font sSelect xSelect yText style.text))
(renderer.draw_text style.font (textNew:sub iLim) xTail yText style.text)
(when (or (active? view tag)
(< (% (- (love.timer.getTime) view.imstate.focus.blink) (* blink_period 2)) blink_period))
(renderer.draw_rect (x-from-i textNew view.imstate.focus.i xText style.font) yText style.caret_width hText style.caret)))
; just draw the text
(renderer.draw_text style.font textNew xText yText style.text))
(love.graphics.setColor 1 1 1)
(values textNew (+ y h)))
(fn textfield [view label text x y wLabel wText]
(renderer.draw_text style.font label x y style.text)
(textbox view label text (+ x wLabel) y wText))
(fn option-text [option]
(match (type option)
:string option
:table (or option.label (tostring option))
_ (tostring option)))
(fn dropdown [view tag selection options x y w]
(local row-h (+ (style.font:get_height) style.padding.y))
(var new-selection nil)
(renderer.draw_rect x y w row-h style.selection)
(renderer.draw_text style.font (option-text selection) (+ x style.padding.x) (+ y (/ style.padding.y 2)) style.text)
(renderer.draw_text style.icon_font "-" (+ x w (- style.padding.x)) (+ y (/ style.padding.y 2)) style.text)
(when (focused? view tag)
(var row-y (+ y row-h))
(each [i option (ipairs options)]
(when (button view [(make-tag tag) i] x row-y w row-h)
(set new-selection option))
(set row-y (+ row-y row-h)))
(postpone view (fn []
(var row-y (+ y row-h))
(each [i option (ipairs options)]
(renderer.draw_rect x row-y w row-h style.selection)
(renderer.draw_text style.font (option-text option) (+ x style.padding.x) (+ row-y (/ style.padding.y 2)) style.text)
(set row-y (+ row-y row-h))))))
(focus view tag x y w row-h)
(values (or new-selection selection) (+ y row-h)))
{: attach-imstate : cmd-predicate : postpone : mouse-inside : activate : active?
: button : checkbox : textbox : textfield : textbutton : dropdown}

View file

@ -3,7 +3,7 @@
(local MapEditView (require :editor.mapedit))
(local ScreenEditView (require :editor.screenedit))
(local PortraitView (require :editor.portraitedit))
(local {: cmd-predicate} (util.require :editor.imstate))
(local {: cmd-predicate} (util.require :editor.imgui))
(local core (require :core))
(local command (require :core.command))
(local keymap (require :core.keymap))
@ -43,6 +43,7 @@
"graphics-editor:next-tile" #(core.active_view:select-rel 1)
"graphics-editor:previous-tile" #(core.active_view:select-rel -1)
})
(command.add (cmd-predicate :editor.tileedit) {
"tileedit:copy"
#(system.set_clipboard (: (core.active_view:tile) :tohex))

View file

@ -3,45 +3,68 @@
(local util (require :lib.util))
(local lume (require :lib.lume))
(local files (require :game.files))
(local {: mouse-inside : activate : active? : checkbox : textfield : textbutton : textbox : dropdown} (util.require :editor.imstate))
(local {: show} (util.require :inspector.debug))
(local {: mouse-inside : activate : active? : checkbox : textfield : textbutton : textbox : dropdown : labelled-dropdown : under : right-of : reform : group-wrapper} (util.require :editor.imgui))
(local {: tilestrip-to-sprite} (util.require :editor.tiledraw))
(local {: encode-yx : encode-itile : decode-itile} (util.require :game.tiles))
(local {: encode-yx : encode-itile : decode-itile : dimensions} (util.require :game.tiles))
(local actions (require :editor.actions))
(local MapEditView (GraphicsEditView:extend))
(local sprite-scale 3)
(local mapw 20)
(local maph 12)
(local tilew (* sprite-scale 14))
(local tileh (* sprite-scale 16))
(fn platform [?key] (let [p (dimensions)] (if ?key (. p ?key) p)))
(fn MapEditView.layer [self ?ilayer] (or (?. (platform :layers) (or ?ilayer self.ilayer)) {:style :tiles}))
(fn MapEditView.layer-type [self ?ilayer] (. (self:layer ?ilayer) :style))
(fn MapEditView.layer-offset [self ?ilayer] (let [{: x : y} (self:layer ?ilayer)] [(* sprite-scale (or x 0)) (* sprite-scale (or y 0))]))
(fn MapEditView.dimensions [self ?ilayer] (or (platform (self:layer-type ?ilayer)) (platform)))
(fn MapEditView.scaled-dimensions [self ?ilayer]
(let [dim (lume.clone (self:dimensions ?ilayer))]
(each [_ key (ipairs [:tilew :tileh :xstagger :ystagger])]
(when (. dim key) (tset dim key (* sprite-scale (. dim key)))))
dim))
(fn MapEditView.mapw [self ?ilayer] (. (self:dimensions ?ilayer) :mapw))
(fn MapEditView.maph [self ?ilayer] (. (self:dimensions ?ilayer) :maph))
(fn MapEditView.tilew [self ?ilayer] (. (self:scaled-dimensions ?ilayer) :tilew))
(fn MapEditView.tileh [self ?ilayer] (. (self:scaled-dimensions ?ilayer) :tileh))
(fn MapEditView.empty-map [self ?ilayer] (string.rep "\0" (* (self:mapw ?ilayer) (self:maph ?ilayer))))
(fn MapEditView.new [self]
(MapEditView.super.new self)
(set self.sprite-scale sprite-scale)
(set self.stripcache {})
(set self.ilevel 1)
(self:set-ilayer 1)
(self:reload))
; map is stored bottom-to-top
(fn imap-from-xy [mx my]
(+ mx -1 (* mapw (- maph my))))
(fn MapEditView.imap-from-xy [self mx my ?ilayer]
(+ mx -1 (* (self:mapw ?ilayer) (- (self:maph ?ilayer) my))))
(fn update-map [map mx my itile]
(local imap (imap-from-xy mx my))
(fn MapEditView.update-map [self map mx my itile]
(local imap (self:imap-from-xy mx my))
(local enctile (encode-itile itile))
(..
(map:sub 1 imap)
(string.char enctile)
(map:sub (+ imap 2))))
(fn MapEditView.itile-from-xy [self mx my]
(local imap (+ (imap-from-xy mx my) 1))
(local enctile (string.byte (self.level.map:sub imap imap)))
(fn MapEditView.map [self ?ilayer]
(if (platform :layers) (or (?. self.level.layers (or ?ilayer self.ilayer)) (self:empty-map ?ilayer))
self.level.map))
(fn MapEditView.itile-from-xy [self mx my ?ilayer]
(local imap (+ (self:imap-from-xy mx my ?ilayer) 1))
(local enctile (or (string.byte (string.sub (self:map ?ilayer) imap imap)) 0))
(decode-itile enctile))
(fn MapEditView.set-tile [self mx my itile]
(set self.level.map (update-map self.level.map mx my itile)))
(let [updated-map (self:update-map (self:map) mx my itile)]
(if (platform :layers) (util.nested-tset self.level [:layers self.ilayer] updated-map)
(set self.level.map updated-map))))
; todo: objects exist on layers
(fn MapEditView.iobject-from-xy [self mx my ?iobj]
(local iobj (or ?iobj 1))
(local obj (. self.level.objects iobj))
@ -60,23 +83,36 @@
(when (. objects (+ iobjectsrc 1))
(move-object objects (+ iobjectsrc 1) iobjectsrc)))
(fn MapEditView.draw-map-selector [self x y]
(renderer.draw_text style.font "Map" x (+ y (/ style.padding.y 2)) style.text)
(let [options {}
level-count (length files.game.levels)
_ (do (for [i 1 level-count] (tset options i i))
(table.insert options :New))
(ilevel yNext) (dropdown self :map-selector self.ilevel options (+ x (* 50 SCALE)) y (* 100 SCALE))]
(fn MapEditView.levels [self]
(when (= files.game.levels nil)
(set files.game.levels []))
files.game.levels)
(fn MapEditView.draw-map-selector [self form]
(let [level-count (length (self:levels))
options (icollect [i (util.countiter (+ level-count 1))] (if (<= i level-count) i :New))
ilevel (labelled-dropdown (reform form {:tag :map-selector :wdropdown (* 100 SCALE)}) "Map" self.ilevel options)]
(when (not= ilevel self.ilevel)
(set self.ilevel (if (= ilevel :New) (+ level-count 1) ilevel))
(self:load-level))
(- yNext y)))
(self:load-level))))
(fn MapEditView.set-ilayer [self ilayer]
(set self.ilayer ilayer)
(self:set-style (self:layer-type)))
(fn MapEditView.draw-layer-selector [self {: x : y &as form}]
(let [mkopt (fn [ilayer] {: ilayer :label (.. ilayer " (" (self:layer-type ilayer) ")")})
options (icollect [ilayer (ipairs (platform :layers))] (mkopt ilayer))
selection (labelled-dropdown (reform form {:wdropdown (* 100 SCALE) :tag :layer-selector}) "Layer" (mkopt self.ilayer) options)]
(when (not= self.ilayer selection.ilayer)
(self:set-ilayer selection.ilayer))))
(fn MapEditView.linking-obj [self] (. self.level.objects self.iobject-linking))
(fn MapEditView.draw-link-line [self x y iobjectSrc color toMouse?]
(local objectSrc (. self.level.objects iobjectSrc))
(local objectDest (. self.level.objects objectSrc.link))
(local coord (fn [c m d] (+ c (* (- m 1) d) (/ d 2))))
(local [tilew tileh] [(self:tilew) (self:tileh)])
(local xStart (coord x objectSrc.x tilew))
(local yStart (coord y objectSrc.y tileh))
(when (or toMouse? objectDest)
@ -87,54 +123,60 @@
(love.graphics.circle :line xEnd yEnd (/ tilew 5))
(love.graphics.setColor 1 1 1)))
(fn MapEditView.draw-tilestrip [self x y my]
(fn MapEditView.draw-link-lines [self {: x : y} iobject-over]
(for [iobject 1 (length self.level.objects)]
(self:draw-link-line x y iobject [0 0 1 0.3]))
(when (not= iobject-over nil) (self:draw-link-line x y iobject-over [0 0.5 1] false))
(when (not= self.iobject-linking nil)
(if (= self.imstate.left :released) (set self.iobject-linking nil)
(self:draw-link-line x y self.iobject-linking [0 1 0] true))))
(fn MapEditView.draw-tilestrip [self x y my ?ilayer translucent?]
; stripcache leaks but honestly who cares
(local tilestrip [])
(var stripid "")
(for [mx 1 mapw]
(local itile (self:itile-from-xy mx my))
(local tile (?. self.tilecache.tiles itile :gfx))
(var stripid (tostring ?ilayer))
(for [mx 1 (self:mapw ?ilayer)]
(local itile (self:itile-from-xy mx my ?ilayer))
(local tile (?. (files.cache (self:layer-type ?ilayer)) :tiles itile :gfx))
(table.insert tilestrip tile)
(set stripid (.. stripid (string.char itile))))
(var sprite (. self.stripcache stripid))
(when (= sprite nil)
(set sprite (tilestrip-to-sprite tilestrip))
(set sprite (tilestrip-to-sprite tilestrip (self:layer-type ?ilayer)))
(tset self.stripcache stripid sprite))
(love.graphics.setColor 1 1 1 (if translucent? 0.4 1))
(love.graphics.draw sprite x y 0 self.sprite-scale self.sprite-scale))
(fn MapEditView.draw-map-editor [self x y]
(love.graphics.setColor 1 1 1 1)
(local button-state self.imstate.left)
(activate self :map x y (* tilew mapw) (* tileh maph))
(var iobject-over nil)
(for [my 1 maph]
(local tiley (+ y (* (- my 1) tileh)))
(self:draw-tilestrip x tiley my)
(for [mx 1 mapw]
(local tilex (+ x (* (- mx 1) tilew)))
(local itile (self:itile-from-xy mx my))
(local iobject (self:iobject-from-xy mx my))
(when (= self.itile nil)
(each [_ player (ipairs (or files.game.players [:player]))]
(match (. self.level player)
{:x mx :y my} (renderer.draw_text style.font player tilex tiley style.text)))
(love.graphics.setColor 1 1 1))
(when (and (not= iobject nil) (= self.itile nil))
(love.graphics.setColor 1 0 (if (and (= self.itile nil) (= iobject self.iobject)) 1 0))
(love.graphics.setLineWidth 3)
(love.graphics.rectangle :line tilex tiley tilew tileh)
(love.graphics.setColor 1 1 1))
(when (mouse-inside tilex tiley tilew tileh)
(when (not= iobject nil) (set iobject-over iobject))
(renderer.draw_text style.font (string.format "%x" (encode-yx {:x mx :y my})) tilex (+ tiley 15) style.text)
(love.graphics.setColor 1 1 1))
(when (and self.itile (active? self :map) (mouse-inside tilex tiley tilew tileh) (not= itile self.itile))
(self:set-tile mx my self.itile))
(when (and (= self.itile nil) (active? self :map) (mouse-inside tilex tiley tilew tileh))
(match button-state
:pressed (set self.iobject-linking iobject)
:released
(if (and (not= iobject nil) (= self.iobject-linking iobject))
(fn MapEditView.mapsize [self ilayer]
(let [{: mapw : maph : tilew : tileh : xstagger : ystagger} (self:scaled-dimensions ilayer)
intileh (or ystagger tileh)]
[(+ (or xstagger 0) (* mapw tilew)) (+ tileh (* (- maph 1) intileh))]))
(fn MapEditView.draw-player [self mx my x y]
(each [_ player (ipairs (or files.game.players [:player]))]
(match (. self.level player)
{:x mx :y my} (renderer.draw_text style.font player x y style.text)))
(love.graphics.setColor 1 1 1))
(fn MapEditView.draw-box [self x y w h color thickness]
(love.graphics.setColor (table.unpack color))
(love.graphics.setLineWidth thickness)
(love.graphics.rectangle :line x y w h)
(love.graphics.setColor 1 1 1))
(fn MapEditView.draw-object-box [self x y w h iobject]
(when iobject
(let [color [1 0 (if (and (= self.itile nil) (= iobject self.iobject)) 1 0) 1]]
(self:draw-object-box x y w h color 3))))
(fn MapEditView.handle-mouseedits-object [self mx my x y w h ilayer]
(when (and (active? self [:map ilayer]) (mouse-inside x y w h))
(let [iobject (self:iobject-from-xy mx my)]
(match self.imstate.left
:down (when (= self.iobject-linking nil) (set self.iobject-linking iobject))
:released
(do (if (and (not= iobject nil) (= self.iobject-linking iobject))
(set self.iobject iobject)
(not= self.iobject-linking nil)
@ -145,16 +187,61 @@
(set self.playerpos nil))
(= iobject nil)
(let [tile (self.tilecache:tile itile)]
(let [tile (self.tilecache:tile (self:itile-from-xy mx my ilayer))]
(table.insert self.level.objects {:x mx :y my :func (or tile.word "")})
(set self.iobject (length self.level.objects))))))))
(when (= self.itile nil)
(for [iobject 1 (length self.level.objects)]
(self:draw-link-line x y iobject [0 0 1 0.3]))
(when (not= iobject-over nil) (self:draw-link-line x y iobject-over [0 0.5 1] false))
(when (not= self.iobject-linking nil)
(if (= self.imstate.left :released) (set self.iobject-linking nil)
(self:draw-link-line x y self.iobject-linking [0 1 0] true)))))
(set self.iobject (length self.level.objects))))
(set self.iobject-linking nil))))))
(fn MapEditView.handle-mouseedits-tile [self mx my x y w h ilayer]
(when (and (active? self [:map ilayer]) (mouse-inside x y w h) (not= (self:itile-from-xy mx my ilayer) self.itile))
(self:set-tile mx my self.itile)))
(fn MapEditView.draw-tile-xy-label [self mx my x y h ystagger]
(local labely (math.floor (+ y (- (or ystagger 0)) (/ (- (if ystagger (* ystagger 2) h) (style.font:get_height)) 2))))
(renderer.draw_text style.font (string.format "%x" (encode-yx {:x mx :y my})) (+ x 20) labely style.text)
(love.graphics.setColor 1 1 1))
(fn MapEditView.draw-map-layer [self {: x : y &as form} live ilayer]
(love.graphics.setColor 1 1 1 1)
(local {: mapw : maph : tilew : tileh : xstagger : ystagger} (self:scaled-dimensions ilayer))
(local [xoffset-layer yoffset-layer] (self:layer-offset ilayer))
(local intileh (or ystagger tileh))
(let [[w h] (self:mapsize ilayer)] (lume.extend form {: w : h :tag [:map ilayer]}))
(when live (activate form))
(var iobject-over nil)
(for [my 1 maph]
(local tiley (+ y yoffset-layer (* (- my 1) (or ystagger tileh))))
(local intiley (+ tiley (- tileh intileh)))
(local xoff (+ xoffset-layer (if (and xstagger (= (% my 2) 0)) xstagger 0)))
(self:draw-tilestrip (+ x xoff) tiley my ilayer (and (mouse-inside x y form.w form.h) (not live)))
(when live
(for [mx 1 mapw]
(local tilex (+ x (* (- mx 1) tilew) xoff))
(local iobject (self:iobject-from-xy mx my))
(when (= self.itile nil)
(self:draw-player mx my tilex intiley)
(self:draw-object-box tilex intiley tilew intileh iobject))
(if self.itile
(self:handle-mouseedits-tile mx my tilex intiley tilew intileh ilayer)
(self:handle-mouseedits-object mx my tilex intiley tilew intileh ilayer))
(when (mouse-inside tilex intiley tilew intileh)
(when (not= iobject nil) (set iobject-over iobject))
(self:draw-tile-xy-label mx my tilex intiley tileh ystagger)
(self:draw-box tilex intiley tilew intileh [1 1 1 0.5] 1)))))
(when (and live (= self.itile nil))
(self:draw-link-lines form iobject-over)))
(fn MapEditView.draw-map-editor [self form]
(let [g (group-wrapper form)
layers (platform :layers)]
(if layers
(do (each [ilayer (ipairs (platform :layers))]
(self:draw-map-layer (g) (= ilayer self.ilayer) ilayer))
(let [{: x : y : w : h} (g)]
(when (mouse-inside x y w h)
(self:draw-map-layer form true self.ilayer))))
(self:draw-map-layer form true))
(g)))
(fn condition-label [flag]
(if flag {:label flag : flag} {:label "<always>"}))
@ -165,23 +252,19 @@
(table.insert options (condition-label flag)))
options))
(fn MapEditView.draw-object-code-editor [self object x y]
(var y y)
(fn MapEditView.draw-object-code-editor [self form object]
(var istep-to-delete nil)
(when (not object.steps) (set object.steps []))
(each [istep step (ipairs object.steps)]
(when (textbutton self "X" (+ x (* 280 SCALE)) y)
(when (textbutton (reform form {:x (+ form.x (* 280 SCALE)) :into {}}) "X")
(set istep-to-delete istep))
(set step.condition (. (dropdown self [:code-condition istep] (condition-label step.condition) (condition-options)
(+ x (* 100 SCALE) style.padding.x) y (* 100 SCALE))
:flag))
(set (step.action y) (dropdown self [:code-action istep] (or step.action (. actions.actionlist 1)) actions.actionlist x y (* 100 SCALE)))
(set y (actions.edit step self x y (* 300 SCALE) istep))
(set y (+ y style.padding.y)))
(set step.condition (. (dropdown (reform form {:x (+ form.x (* 150 SCALE)) :w (* 100 SCALE) :tag [:code-condition istep] :into {}}) (condition-label step.condition) (condition-options)) :flag))
(set step.action (dropdown (reform form {:w (* 100 SCALE) :tag [:code-action istep]}) (or step.action (. actions.actionlist 1)) actions.actionlist))
(actions.edit step (under form {:w (* 300 SCALE)}) istep)
(under form))
(when istep-to-delete (table.remove object.steps istep-to-delete))
(let [(do-new y) (textbutton self "+ New Step" x (+ y style.padding.y))]
(when do-new (table.insert object.steps {}))
y))
(when (textbutton (under form) "+ New Step")
(table.insert object.steps {})))
(fn advanced? [object]
(or object.advanced
@ -189,42 +272,41 @@
(not= object.func "")
(not= object.func nil))))
(fn MapEditView.draw-object-advanced-editor [self object x y]
(let [(func y) (textfield self "Word" object.func x y (* 100 SCALE) (* 200 SCALE))
(name y) (textfield self "Name" object.name x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE))
(linkword y) (textfield self "Link word" object.linkword x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE))
(do-unlink y) (if object.link (textbutton self "Unlink" x (+ y style.padding.y)) (values false y))
(linkentity y) (if object.link (values object.linkentity y) (textfield self "Link entity" object.linkentity x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE)))]
(lume.extend object {: func : name : linkword : linkentity})
(when do-unlink (set object.link nil))
y))
(fn MapEditView.draw-object-advanced-editor [self form object]
(let [fieldform {:wlabel (* 100 SCALE) :wtext (* 200 SCALE)}]
(set object.func (textfield (reform form fieldform) "Word" object.func))
(set object.name (textfield (under form fieldform) "Name" object.name))
(set object.linkword (textfield (under form fieldform) "Link word" object.linkword))
(if object.link
(when (textbutton (under form) "Unlink")
(set object.link nil))
(set object.linkentity (textfield (under form fieldform) "Link entity" object.linkentity)))))
(fn MapEditView.draw-object-editor [self x y]
(fn MapEditView.draw-object-editor [self form]
(let [object (self:object)
y (if (advanced? object)
(self:draw-object-advanced-editor object x y)
(self:draw-object-code-editor object x y))
new-flag-name (textbox self :new-flag-name self.new-flag-name x (+ y style.padding.y) (* 200 SCALE))
(mk-new-flag y) (textbutton self "+ New Flag" (+ x (* 200 SCALE) style.padding.x) (+ y style.padding.y))
do-delete (textbutton self "Delete" x (+ y (* style.padding.y 2)))
(do-advanced y) (textbutton self (if (advanced? object) "Simple" "Advanced") (+ x (* 150 SCALE)) (+ y (* style.padding.y 2)))]
(set self.new-flag-name new-flag-name)
(when mk-new-flag
footer (group-wrapper form)]
(if (advanced? object)
(self:draw-object-advanced-editor form object)
(self:draw-object-code-editor form object))
(set self.new-flag-name (footer textbox (under form {:tag :new-flag-name :w (* 200 SCALE)}) self.new-flag-name))
(when (footer textbutton (right-of form) "+ New Flag")
(when (= files.game.flags nil)
(set files.game.flags []))
(table.insert files.game.flags new-flag-name)
(table.insert files.game.flags self.new-flag-name)
(set self.new-flag-name ""))
(when do-delete
(when (footer textbutton (under (footer)) "Delete")
(move-object self.level.objects (+ self.iobject 1) self.iobject)
(set self.iobject nil))
(when do-advanced (set object.advanced (not (advanced? object))))
y))
(when (footer textbutton (right-of form) (if (advanced? object) "Simple" "Advanced"))
(set object.advanced (not (advanced? object))))
(footer)))
(fn MapEditView.load-level [self]
(set self.stripcache {})
(when (= (. files.game.levels self.ilevel) nil)
(tset files.game.levels self.ilevel {:map (string.rep "\0" (* mapw maph)) :objects []}))
(set self.level (. files.game.levels self.ilevel))
(when (= (. (self:levels) self.ilevel) nil)
(tset (self:levels) self.ilevel {:map (self:empty-map) :objects []}))
(set self.level (. (self:levels) self.ilevel))
(set self.iobject nil))
(fn MapEditView.reload [self]
@ -232,42 +314,36 @@
(self:load-level))
(fn MapEditView.draw [self]
(var x (+ self.position.x style.padding.x (- self.scroll.x)))
(var y (+ self.position.y style.padding.y (- self.scroll.y)))
(self:draw_background style.background)
(self:draw_scrollbar)
(local ytop y)
(local editor-on-side (> self.size.x (+ (* tilew mapw) (* 300 SCALE))))
(set y (+ y (self:draw-map-selector x y) style.padding.y))
(self:draw-map-editor x y)
(set y (+ y (* tileh maph) style.padding.y))
(set y (+ y (self:draw-tile-selector x y (if editor-on-side (* tilew mapw)
(- self.size.x (* style.padding.x 2))))))
(set (self.level.tickword y) (textfield self "Tick word" self.level.tickword x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE)))
(set (self.level.moveword y) (textfield self "Move word" self.level.moveword x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE)))
(set (self.level.loadword y) (textfield self "Load word" self.level.loadword x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE)))
(let [(checked y-new) (checkbox self "Edit objects" (= self.itile nil) x (+ y style.padding.y))
_ (when checked
(set self.itile nil)
(set self.playerpos nil))]
(set y y-new)
(let [form (self:form)
form-editor (self:form)
header (group-wrapper form)
_ (header #(self:draw-map-selector $...) form)
_ (when (platform :layers) (header #(self:draw-layer-selector $...) (right-of form)))
_ (self:draw-map-editor (under (header)))
editor-on-side (> self.size.x (+ form.w (* 300 SCALE)))
fieldform {:wlabel (* 100 SCALE) :wtext (* 200 SCALE)}]
(when editor-on-side
(set form-editor.x (+ form.x form.w style.padding.x))
(set form-editor.w (- form-editor.w form.w style.padding.x)))
(self:draw-tile-selector (under form {:w (if editor-on-side form.w (- self.size.x (* style.padding.x 2)))}))
(set self.level.tickword (textfield (under form fieldform) "Tick word" self.level.tickword))
(set self.level.moveword (textfield (under form fieldform) "Move word" self.level.moveword))
(set self.level.loadword (textfield (under form fieldform) "Load word" self.level.loadword))
(when (checkbox (under form) "Edit objects" (= self.itile nil))
(set self.itile nil)
(set self.playerpos nil))
(each [_ player (ipairs (or files.game.players [:player]))]
(let [(checked y-new) (checkbox self (.. "Position " player) (and (= self.itile nil) (= self.playerpos player)) x (+ y style.padding.y))]
(when checked
(set self.itile nil)
(set self.playerpos player))
(set y y-new))))
(each [_ levelflag (ipairs (or files.game.levelflags []))]
(let [(checked y-new) (checkbox self levelflag (. self.level levelflag) x (+ y style.padding.y))]
(when checked (tset self.level levelflag (not (. self.level levelflag))))
(set y y-new)))
(when self.iobject
(set y (math.max y (if editor-on-side
(self:draw-object-editor (+ x (* tilew mapw) style.padding.x) ytop)
(self:draw-object-editor x (+ y style.padding.y))))))
(set self.scrollheight (+ y (- self.position.y) self.scroll.y style.padding.y)))
(when (checkbox (under form) (.. "Position " player) (and (= self.itile nil) (= self.playerpos player)))
(set self.itile nil)
(set self.playerpos player)))
(each [_ levelflag (ipairs (or files.game.levelflags []))]
(when (checkbox (under form) levelflag (. self.level levelflag))
(tset self.level levelflag (not (. self.level levelflag)))))
(when (not editor-on-side) (set form-editor.y (+ form.y form.h style.padding.y)))
(when self.iobject (self:draw-object-editor form-editor))
(self:end-scroll (if (> (+ form.y form.h) (+ form-editor.y (or form-editor.h 0))) form form-editor))))
(fn MapEditView.get_name [self] (.. "Map " self.ilevel))

View file

@ -2,27 +2,16 @@
(local TileView (require :editor.tileedit))
(local tiledraw (require :editor.tiledraw))
(local tiles (require :game.tiles))
(local {: textfield} (util.require :editor.imstate))
(local {: textfield} (util.require :editor.imgui))
(local PortraitView (TileView:extend))
(fn PortraitView.tilesize [self] (values 32 32))
(fn PortraitView.tilekeys [self] [:gfx])
(fn PortraitView.resource-key [self] :portraits)
(fn PortraitView.map-bitxy [self x y]
(local quadrant (+ (if (>= x 16) 2 0) (if (>= y 16) 1 0)))
(local tilex
(if (or (= x 0) (= x 30)) 0
(or (= x 1) (= x 31)) 15
(< x 16) (- x 1)
(- x 15)))
(local tiley (% y 16))
(local (ibyte ibit) (PortraitView.super.map-bitxy self tilex tiley))
(values (+ ibyte (* quadrant 32)) ibit))
(fn PortraitView.draw-tile-flags [self x y]
(fn PortraitView.initial-style [self] :portraits)
(fn PortraitView.draw-sidebar [self form]
(local tile (-?> self.tilecache.tiles (. self.itile)))
(when tile
(set tile.label (textfield self "Label" tile.label x (+ y 4) 100 200))))
(set tile.label (textfield form "Label" tile.label))))
(fn PortraitView.get_name [self] "Portrait Editor")

View file

@ -2,23 +2,22 @@
(local fennel (require :lib.fennel))
(local style (require :core.style))
(local lume (require :lib.lume))
(local {: textbutton} (util.require :editor.imstate))
(local {: textbutton : under : group-wrapper} (util.require :editor.imgui))
(local {: inspect} (util.require :inspector))
(local repl (util.hot-table ...))
(fn repl.inspector [{: vals : states} view x y]
(var h 0)
(each [i v (ipairs vals)]
(set h (+ h (inspect (. states i) v view x (+ y h) view.size.x))))
(+ h style.padding.y))
(fn repl.inspector [{: w &as form} {: vals : states}]
(let [g (group-wrapper form)]
(each [i v (ipairs vals)]
(g #(inspect $...) (under (g) {: w}) (. states i) v))
(g)))
(fn repl.notify [listeners line]
(each [_ listener (ipairs listeners)]
(listener:append line)))
(fn repl.mk-result [vals]
(local inspector #(repl.inspector $...))
{:draw inspector : vals :states (icollect [_ (ipairs vals)] {})})
{:draw repl.inspector : vals :states (icollect [_ (ipairs vals)] {})})
(fn repl.run [{: listeners}]
(fennel.repl {:readChunk coroutine.yield

View file

@ -1,5 +1,5 @@
(local util (require :lib.util))
(local {: attach-imstate : textbox} (util.require :editor.imstate))
(local {: attach-imstate : textbox : textbutton : label : under : reform : group-wrapper : mouse-inside} (util.require :editor.imgui))
(local View (require :core.view))
(local style (require :core.style))
@ -13,6 +13,7 @@
(set self.cmd "")
(set self.scrollheight math.huge)
(set self.scrollable true)
(set self.title "REPL")
(self.conn:listen self))
(fn ReplView.try_close [self do_close]
@ -24,38 +25,36 @@
(fn ReplView.append [self line]
(table.insert self.log line))
(fn ReplView.draw-cmd [{: cmd} view x y]
(renderer.draw_text style.font cmd x y style.text)
(+ (style.font:get_height) style.padding.y))
(fn ReplView.draw-cmd [{: x : y : w : view &as form} {: cmd} iline]
(label form cmd)
(when (mouse-inside x y w form.h)
(when (textbutton (reform form {:x (+ x w -35) :into {}}) :X)
(table.remove view.log iline)
(table.remove view.log iline))
(when (textbutton (reform form {:x (+ x w -60) :into {}}) :!)
(view:submit cmd))))
(fn ReplView.submit [self ?cmd]
(local cmd (or ?cmd self.cmd))
(when (= ?cmd nil)
(set self.cmd ""))
(self:append {:draw #(self.draw-cmd $...) : cmd})
(self:append {:draw self.draw-cmd : cmd})
(self.conn:submit cmd))
(fn ReplView.draw [self]
(self:draw_background style.background)
(self:draw_scrollbar)
(var x (- self.position.x self.scroll.x))
(var y (- self.position.y self.scroll.y))
(var rendered-h 0)
(let [{: w &as form} (self:form)
g (group-wrapper form)]
; todo: cache sizes and avoid drawing if offscreen?
; note: then offscreen items can't be focussed without further effort
; todo: draw line numbers
(each [i line (ipairs self.log)]
(g line.draw (under (g) {: w}) line i))
(set self.cmd (g textbox (under (g) {: w :tag :command}) self.cmd))
(self:end-scroll (g))))
; todo: cache sizes and avoid drawing if offscreen?
; note: then offscreen items can't be focussed without further effort
; todo: draw line numbers
(each [i line (ipairs self.log)]
(let [h (line:draw self x y)]
(set y (+ y h))
(set rendered-h (+ rendered-h h))))
(set self.cmd (textbox self :command self.cmd x y self.size.x))
(local pin-to-bottom (>= self.scroll.to.y (- self.scrollheight self.size.y)))
(set self.scrollheight (+ rendered-h (style.font:get_height) 4))
(when pin-to-bottom
(set self.scroll.to.y (- self.scrollheight self.size.y))))
(fn ReplView.get_name [self] self.title)
ReplView

View file

@ -3,7 +3,7 @@
(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 {: mouse-inside : activate : active?} (util.require :editor.imgui))
(local ScreenEditView (GraphicsEditView:extend))
(local screen-scale 4)
@ -54,7 +54,7 @@
(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)
(activate {:view self :tag :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)))

View file

@ -1,3 +1,5 @@
(local {: putpixel : make-canvas} (require :editor.tiledraw))
(fn pal-from-bit [bit]
(if bit
(values [20 207 253] [255 106 60])
@ -6,25 +8,6 @@
(fn pal-from-byte [byte]
(pal-from-bit (not= 0 (bit.band byte 0x80))))
(fn putpixel [x y color]
(when color
(love.graphics.setColor (/ (. color 1) 255) (/ (. color 2) 255) (/ (. color 3) 255))
(love.graphics.points (+ x 0.5) (+ y 0.5))))
(fn make-canvas [w h f]
(local canvas (love.graphics.newCanvas w h))
(local prevcanvas (love.graphics.getCanvas))
(canvas:setFilter :nearest :nearest)
(local scissor [(love.graphics.getScissor)])
(love.graphics.setScissor)
(love.graphics.setCanvas canvas)
(love.graphics.clear 0 0 0)
(f canvas)
(love.graphics.setCanvas prevcanvas)
(love.graphics.setScissor (table.unpack scissor))
(love.graphics.setColor 1 1 1 1)
canvas)
(fn draw-byte [bytes ibyte xoffset y ?state ?prevpal]
(local byte (string.byte (bytes:sub ibyte ibyte)))
(var prevstate nil)
@ -105,32 +88,5 @@
(for [y 0 7]
(draw-byte gfx (+ y 1) 0 y))))))
(fn TileCache [tiles ?spritegen]
{: tiles
:spritegen (or ?spritegen tile-to-sprite)
:tilesprites []
:tile (fn [self itile] (or (. self.tiles itile) {:flags {}}))
:cachekey (fn [itile ?key] (.. (or ?key :gfx) itile))
:update-tile
(fn [self itile tile ?key]
(tset self.tiles itile
(-> (self:tile itile)
(doto (tset (or ?key :gfx) tile))))
(tset self.tilesprites (self.cachekey itile ?key) nil))
:set-flag
(fn [self itile flag clear]
(tset (. self.tiles itile :flags) flag (if clear nil true)))
:load
(fn [self tiles]
(set self.tiles tiles)
(set self.tilesprites []))
:sprite
(fn [self itile ?key]
(local key (self.cachekey itile ?key))
(when (and (= nil (. self.tilesprites key)) (not= nil (. self.tiles itile)))
(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 : scanline-to-sprite
: screen-y-to-offset : pal-from-bit : pal-from-byte : TileCache : make-canvas : draw-byte}
{: tile-to-sprite : char-to-sprite : portrait-to-sprite : screen-to-sprite : scanline-to-sprite : screen-y-to-offset
: tilestrip-to-sprite : pal-from-bit : pal-from-byte : draw-byte}

29
editor/tiledraw/iigs.fnl Normal file
View file

@ -0,0 +1,29 @@
(local {: putpixel : make-canvas} (require :editor.tiledraw))
(local tiles (require :game.tiles))
; converted from http://pixeljoint.com/forum/forum_posts.asp?TID=12795 (db16)
; maybe check out https://lospec.com/palette-list ?
(local pal [[1 0 1] [4 2 3] [3 3 6] [4 4 4] [8 4 3] [3 6 2] [13 4 4] [7 7 6]
[5 7 12] [13 7 2] [8 9 10] [6 10 2] [13 10 9] [6 12 12] [13 13 5] [13 14 13]])
(fn gs-to-rgb [color] (icollect [_ v (ipairs (or color [0 0 0]))] (* v 0x11)))
(fn spritegen-for-size [w h]
(fn [tile]
(when tile (make-canvas w h (fn [canvas]
(love.graphics.clear 0 0 0 0)
(for [y 0 (- h 1)]
(for [x 0 (- w 1)]
(let [ibyte (+ (* y w) x 1)
byte (string.byte (tile:sub ibyte ibyte))
mask (bit.band (bit.rshift byte 4) 0xf)
color (bit.band byte 0xf)
rgb (if (= mask 0) (gs-to-rgb (. pal (+ color 1))) [255 0 255])]
(when (= mask 0) (putpixel x y rgb))))))))))
(local tile-to-sprite (spritegen-for-size 16 16))
(fn spritegen-for-style [name]
(let [{: tilew : tileh} (tiles.style name)]
(spritegen-for-size tilew tileh)))
{: tile-to-sprite : spritegen-for-size : spritegen-for-style : pal : gs-to-rgb}

69
editor/tiledraw/init.fnl Normal file
View file

@ -0,0 +1,69 @@
(local files (require :game.files))
(local TileDraw {})
(fn TileDraw.putpixel [x y color]
(when color
(love.graphics.setColor (/ (. color 1) 255) (/ (. color 2) 255) (/ (. color 3) 255))
(love.graphics.points (+ x 0.5) (+ y 0.5))))
(fn TileDraw.make-canvas [w h f]
(local canvas (love.graphics.newCanvas w h))
(local prevcanvas (love.graphics.getCanvas))
(canvas:setFilter :nearest :nearest)
(local scissor [(love.graphics.getScissor)])
(love.graphics.setScissor)
(love.graphics.setCanvas canvas)
(love.graphics.clear 0 0 0 0)
(f canvas)
(love.graphics.setCanvas prevcanvas)
(love.graphics.setScissor (table.unpack scissor))
(love.graphics.setColor 1 1 1 1)
canvas)
(files.platform-methods TileDraw :editor.tiledraw
:tile-to-sprite :char-to-sprite :portrait-to-sprite :screen-to-sprite :screen-y-to-offset
:pal-from-bit :pal-from-byte :draw-byte)
(files.default-platform-method TileDraw :editor.tiledraw :tilestrip-to-sprite
(fn [tiles style]
(let [spritegen (TileDraw.spritegen-for-style style)
sprites (icollect [_ tile (ipairs tiles)] (spritegen tile))]
(TileDraw.make-canvas (* (: (. sprites 1) :getWidth) (length sprites)) (: (. sprites 1) :getHeight)
#(each [isprite sprite (ipairs sprites)]
(love.graphics.draw sprite (* (sprite:getWidth) (- isprite 1)) 0))))))
(files.default-platform-method TileDraw :editor.tiledraw :spritegen-for-style
(fn [style]
(match style
:font TileDraw.char-to-sprite
:brushes TileDraw.char-to-sprite
:portraits TileDraw.portrait-to-sprite
_ TileDraw.tile-to-sprite)))
(fn TileDraw.TileCache [tiles ?spritegen]
{: tiles
:spritegen (or ?spritegen TileDraw.tile-to-sprite)
:tilesprites []
:tile (fn [self itile] (or (. self.tiles itile) {:flags {}}))
:cachekey (fn [itile ?key] (.. (or ?key :gfx) itile))
:update-tile
(fn [self itile tile ?key]
(tset self.tiles itile
(-> (self:tile itile)
(doto (tset (or ?key :gfx) tile))))
(tset self.tilesprites (self.cachekey itile ?key) nil))
:set-flag
(fn [self itile flag clear]
(tset (. self.tiles itile :flags) flag (if clear nil true)))
:load
(fn [self tiles]
(set self.tiles tiles)
(set self.tilesprites []))
:sprite
(fn [self itile ?key]
(local key (self.cachekey itile ?key))
(when (and (= nil (. self.tilesprites key)) (not= nil (. self.tiles itile)))
(tset self.tilesprites key (self.spritegen (. self.tiles itile (or ?key :gfx)))))
(. self.tilesprites key))})
TileDraw

View file

@ -1,109 +0,0 @@
(local GraphicsEditView (require :editor.gfxedit))
(local style (require :core.style))
(local tiles (require :game.tiles))
(local files (require :game.files))
(local tiledraw (require :editor.tiledraw))
(local util (require :lib.util))
(local {: mouse-inside : activate : active? : checkbox : textfield} (util.require :editor.imstate))
(local TileView (GraphicsEditView:extend))
(set TileView.pixel-size 24)
(local pixel-size TileView.pixel-size)
(fn TileView.map-bitxy [self x y]
(when (and (>= x 0) (< x 16) (>= y 0) (< y 16))
(local ibyte (if (< x 8) y (+ y 16)))
(local ibit
(if (= x 0) 7
(< x 8) (- x 1)
(- x 8)))
(values ibyte ibit)))
(fn TileView.tilesize [self] (values 16 16))
(fn TileView.tilekeys [self]
(if files.game.tilesets (icollect [_ key (pairs files.game.tilesets)] key)
[:gfx]))
(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]
(util.splice tile ibyte (string.char (set-bit tile ibyte ibit is-set))))
(fn draw-bit-color [bit x y]
(local (bgcolor color) (tiledraw.pal-from-bit bit))
(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 TileView.tile [self]
(local (w h) (self:tilesize))
(or (-?> self.tilecache.tiles (. self.itile) (. (or self.tilekey :gfx))) (string.rep "\0" (/ (* w h) 8))))
(fn TileView.draw-tile-editor [self tile x y]
(when (not (active? self :tile))
(set self.bit nil))
(local (w h) (self:tilesize))
(local editor-w (* (+ pixel-size 1) w))
(local editor-h (* (+ pixel-size 1) h))
(activate self :tile x y editor-w editor-h)
(for [bitx 0 (- w 1)] (for [bity 0 (- h 1)]
(local (ibyte ibit) (self:map-bitxy bitx bity))
(local b (get-bit tile ibyte ibit))
(local (px py) (values (+ x (* bitx (+ pixel-size 1))) (+ y (* bity (+ pixel-size 1)))))
(if (= ibit 7)
(draw-bit-color b px py)
(draw-bit b px py (= (% bitx 2) 1)))
(when (and (active? self :tile) (mouse-inside px py pixel-size pixel-size))
(when (= self.bit nil) (set self.bit (not b)))
(when (not= self.bit b)
(self:update-tile (set-tile-bit tile ibyte ibit self.bit))))))
(love.graphics.setColor 1 1 1 1)
(values editor-w editor-h))
(fn TileView.draw-tile-flag [self flagname x y]
(local flags (-?> self.tilecache.tiles (. self.itile) (. :flags)))
(local flagset (if flags (. flags flagname) false))
(let [(checked yNew) (checkbox self flagname flagset x y)]
(when checked (tset flags flagname (if flagset nil true)))
yNew))
(fn TileView.draw-tile-flags [self x y]
(local tile (-?> self.tilecache.tiles (. self.itile)))
(var y y)
(when tile
(set (tile.word y) (textfield self "Default word" tile.word x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE)))
(set (tile.label y) (textfield self "Label" tile.label x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE))))
(each [iflag flagname (ipairs (tiles.flags))]
(set y (self:draw-tile-flag flagname x (+ y style.padding.y)))))
(fn TileView.update-tile [self newtile]
(self.tilecache:update-tile self.itile newtile self.tilekey))
(fn TileView.draw [self]
(self:draw_background style.background)
(self:draw_scrollbar)
(local (x y) (values (+ self.position.x style.padding.x (- self.scroll.x))
(+ self.position.y style.padding.y (- self.scroll.y))))
(local (editor-w editor-h) (self:draw-tile-editor (self:tile) x y))
(self:draw-tile-flags (+ x editor-w pixel-size) y)
(var selector-y (+ y editor-h pixel-size))
(each [_ key (ipairs (self:tilekeys))]
(local selector-h (self:draw-tile-selector x selector-y (- self.size.x 20) key))
(set selector-y (+ selector-y selector-h pixel-size)))
(set self.scrollheight (- selector-y y)))
(fn TileView.resource-key [self] :tiles)
(fn TileView.get_name [self] "Tile Editor")
TileView

33
editor/tileedit/ii.fnl Normal file
View file

@ -0,0 +1,33 @@
(local tiledraw (require :editor.tiledraw))
(fn map-bitxy-tile [x y]
(when (and (>= x 0) (< x 16) (>= y 0) (< y 16))
(local ibyte (if (< x 8) y (+ y 16)))
(local ibit
(if (= x 0) 7
(< x 8) (- x 1)
(- x 8)))
(values ibyte ibit 1)))
(fn map-bitxy-portrait [x y]
(local quadrant (+ (if (>= x 16) 2 0) (if (>= y 16) 1 0)))
(local tilex
(if (or (= x 0) (= x 30)) 0
(or (= x 1) (= x 31)) 15
(< x 16) (- x 1)
(- x 15)))
(local tiley (% y 16))
(local (ibyte ibit) (map-bitxy-tile tilex tiley))
(values (+ ibyte (* quadrant 32)) ibit 1))
{:map-bitxy (fn [self x y w] (if (> w 16) (map-bitxy-portrait x y) (map-bitxy-tile x y)))
:pixel-color (fn [self b _ ibit]
(if (= ibit 7) (tiledraw.pal-from-bit (= b 1))
(= b 1) [255 255 255]
[0 0 0]))
:draw-off (fn [self] (set self.bit nil))
:draw-on (fn [self b] (when (= self.bit nil) (set self.bit (if (= b 1) 0 1))))
:draw-bits (fn [self] self.bit)
:pixel-storage-divisor #8
}

16
editor/tileedit/iigs.fnl Normal file
View file

@ -0,0 +1,16 @@
(local {: pal : gs-to-rgb} (require :editor.tiledraw.iigs))
(local lume (require :lib.lume))
{:map-bitxy (fn [self x y w h] (values (+ (* y w) x) 0 0xff))
:pixel-color (fn [self b] (match b 0xf0 (values [128 128 128] [64 64 64])
_ (gs-to-rgb (. pal (+ b 1)))))
:draw-bits #(if (= $1.icolor 17) 0xf0 (- $1.icolor 1))
:palette #(lume.concat (icollect [_ color (ipairs pal)] (gs-to-rgb color)) [[255 0 255]])
:pixel-storage-divisor #1
:blank-tile-byte #"\xf0"
:preview-locations (fn [self]
(match self.style
:iso [[12 0] [0 6] [24 6] [12 12]]
_ [[0 0] [12 0] [0 12] [12 12]]))
}

157
editor/tileedit/init.fnl Normal file
View file

@ -0,0 +1,157 @@
(local GraphicsEditView (require :editor.gfxedit))
(local style (require :core.style))
(local tiles (require :game.tiles))
(local files (require :game.files))
(local util (require :lib.util))
(local lume (require :lib.lume))
(local {: show} (util.require :inspector.debug))
(local {: mouse-inside : activate : active? : checkbox : textfield : button : dropdown : with-style
: under : right-of : reform : horiz-wrapper : group-wrapper} (util.require :editor.imgui))
(local TileView (GraphicsEditView:extend))
(set TileView.pixel-size 24)
(local pixel-size TileView.pixel-size)
(fn TileView.tilekeys [self]
(if files.game.tilesets (icollect [_ key (pairs files.game.tilesets)] key)
[:gfx]))
(fn TileView.tilebytelen [self] (let [(w h) (self:tilesize)] (/ (* w h) (self:pixel-storage-divisor))))
(fn get-byte [tile ibyte]
(or (: (tile:sub (+ ibyte 1) (+ ibyte 1)) :byte) 0))
(fn get-bits [tile ibyte ibit mask]
(-> (get-byte tile ibyte)
(bit.band (bit.lshift mask ibit))
(bit.rshift ibit)))
(fn set-bits [tile ibyte ibit mask bits]
(local orval (bit.lshift mask ibit))
(-> (get-byte tile ibyte)
(bit.band (bit.bnot orval))
(bit.bor (bit.lshift bits ibit))))
(fn set-tile-bits [tile ibyte ibit mask bits]
(util.splice tile ibyte (string.char (set-bits tile ibyte ibit mask bits))))
(files.platform-methods TileView :editor.tileedit :map-bitxy :pixel-color :draw-on :draw-off :draw-bits
:palette :pixel-storage-divisor)
(files.default-platform-method TileView :editor.tileedit :preview-locations
(fn [self] (let [(w h) (self:tilesize)] [[0 0] [w 0] [0 h] [w h]])))
(files.default-platform-method TileView :editor.tileedit :blank-tile-byte #"\0")
(fn TileView.tile [self]
(local (w h) (self:tilesize))
(or (-?> self.tilecache.tiles (. self.itile) (. (or self.tilekey :gfx)))
(string.rep (self:blank-tile-byte) (/ (* w h) (self:pixel-storage-divisor)))))
(fn TileView.draw-pixel [self x y colorbg ?colorfg]
(renderer.draw_rect x y pixel-size pixel-size colorbg)
(when ?colorfg (renderer.draw_rect (+ x 3) (+ y 3) (- pixel-size 6) (- pixel-size 6) ?colorfg)))
(fn tile-editor [{:view self : x : y &as form} tile]
(local {: tag} (with-style form :tag :tile))
(when (not (active? self tag)) (self:draw-off))
(local (w h) (self:tilesize))
(set form.w (* (+ pixel-size 1) w))
(set form.h (* (+ pixel-size 1) h))
(activate form)
(for [bitx 0 (- w 1)] (for [bity 0 (- h 1)]
(local (ibyte ibit mask) (self:map-bitxy bitx bity w h))
(local b (get-bits tile ibyte ibit mask))
(local (px py) (values (+ x (* bitx (+ pixel-size 1))) (+ y (* bity (+ pixel-size 1)))))
(local (colorbg colorfg) (self:pixel-color b ibyte ibit))
(self:draw-pixel px py colorbg colorfg)
(when (and (active? self tag) (mouse-inside px py pixel-size pixel-size))
(self:draw-on b)
(local bits (self:draw-bits))
(when (not= bits b)
(self:update-tile (set-tile-bits tile ibyte ibit mask bits))))))
(love.graphics.setColor 1 1 1 1))
(fn TileView.draw-tile-editor [self form tile] (tile-editor form tile))
(fn tile-flag [form tile flagname]
(local flagset (?. tile :flags flagname))
(when (checkbox form flagname flagset)
(tset tile :flags flagname (if flagset nil true))))
(fn TileView.draw-tile-flags [self form]
(let [tile (-?> self.tilecache.tiles (. self.itile))
fieldform {:wlabel (* 100 SCALE) :wtext (* 200 SCALE)}]
(when tile
(set tile.word (textfield (reform form fieldform) "Default word" tile.word))
(set tile.label (textfield (under form fieldform) "Label" tile.label)))
(each [iflag flagname (ipairs (tiles.flags))]
(tile-flag (under form) tile flagname))))
(fn tile-preview [{:view self : x : y &as form} itile tilekey]
(each [_ [tx ty] (ipairs (self:preview-locations))]
(let [dx (* tx self.sprite-scale) dy (* ty self.sprite-scale)
(w h) (self:draw-sprite (+ x dx) (+ y dy) itile tilekey)]
(when (and w (or (= form.w nil) (< form.w (+ w dx)))) (set form.w (+ w dx)))
(when (and h (or (= form.h nil) (< form.h (+ h dy)))) (set form.h (+ h dy))))))
(fn TileView.draw-tile-preview [self form] (tile-preview form self.itile self.tilekey))
(fn tile-palette [{:view self : x : y : w &as form} pal selected-color]
(let [g (group-wrapper (with-style form))
wrap (horiz-wrapper form)]
(var selected-color selected-color)
(each [icolor color (ipairs pal)]
(renderer.draw_rect form.x form.y pixel-size pixel-size color)
(when (= icolor selected-color)
(love.graphics.setColor 1 1 1 1)
(love.graphics.rectangle :line (- form.x 2) (- form.y 2) (+ pixel-size 4) (+ pixel-size 4)))
(when (g button (reform form {:tag [:pal icolor] :w pixel-size :h pixel-size}))
(set selected-color icolor))
(wrap form))
(g)
selected-color))
(fn TileView.draw-tile-palette [self form]
(match (self:palette)
pal (set self.icolor (tile-palette form pal self.icolor))))
(fn TileView.update-tile [self newtile]
(self.tilecache:update-tile self.itile newtile self.tilekey))
(fn style-selector [form current-style]
(let [{:view self : x : y : font : color : ypad} (with-style form)
form-drop (lume.merge form {:x (+ x (* 50 SCALE)) :w (* 100 SCALE) :tag :layer-selector})
selection (dropdown form-drop current-style (tiles.tile-styles))]
(renderer.draw_text font "Style" x (+ y (/ ypad 2)) color)
(set form.w (- (+ form-drop.x form-drop.w) x))
(set form.h form-drop.h)
(when (not= current-style selection) selection)))
(fn TileView.draw-style-selector [self form]
(match (style-selector form self.style)
new-style (self:set-style new-style)))
(fn TileView.draw-sidebar [self form]
(self:draw-tile-flags form)
(self:draw-tile-preview (under form)))
(fn TileView.draw [self]
(self:draw_background style.background)
(self:draw_scrollbar)
(let [form (self:form)
full-width {:w form.w}]
(self:draw-tile-editor form (self:tile))
; layout sidebar
(self:draw-sidebar (right-of form {:into {}}))
; continue laying out under tile editor
(self:draw-tile-palette (under form full-width))
(when (> (length (tiles.tile-styles)) 1)
(self:draw-style-selector (under form)))
(each [_ key (ipairs (self:tilekeys))]
(self:draw-tile-selector (under form full-width) key))
(self:end-scroll form)))
(fn TileView.initial-style [self] :tiles)
(fn TileView.get_name [self] "Tile Editor")
TileView

View file

@ -1,10 +1,9 @@
(local util (require :lib.util))
(local lume (require :lib.lume))
(local tiledraw (require :editor.tiledraw))
(local files (util.hot-table ...))
(local default-filename "bitsy/game.json")
(local default-filename "neutgs/game.json")
(local encoded-tile-fields [:gfx :mask])
(fn convert [tile field method]
@ -30,15 +29,30 @@
(fn deserialize [key value root]
(match key
(where (or :tiles :portraits :font :brushes)) (tile-deserialize value root)
:levels (do (set value.map (value.map:fromhex)) value)
:levels (do (set value.map (value.map:fromhex))
(set value.layers (icollect [_ layer (ipairs (or value.layers []))] (layer:fromhex)))
value)
_ value))
(fn serialize [key value root]
(match key
(where (or :tiles :portraits :font :brushes)) (tile-serialize value root)
:levels (do (set value.map (value.map:tohex)) value)
:levels (do (set value.map (value.map:tohex))
(set value.layers (icollect [_ layer (ipairs (or value.layers []))] (layer:tohex)))
value)
_ value))
; serialization, take 2: just always convert unprintable strings to hex everywhere
(fn deserialize2 [o]
(if (and (= (type o) :table) o.__hex__) (o.__hex__:fromhex)
(= (type o) :table) (collect [k v (pairs o)] (values k (deserialize2 v)))
o))
(fn printable? [s] (= (string.match s "[^%w%s%p]") nil))
(fn serialize2 [o]
(if (and (= (type o) :string) (not (printable? o))) {:__hex__ (o:tohex)}
(= (type o) :table) (collect [k v (pairs o)] (values k (serialize2 v)))
o))
(fn clone [v]
(match (type v)
:table (lume.clone v)
@ -49,30 +63,31 @@
(when ?filename (set files.filename ?filename))
(set files.game
(if (util.file-exists (filename))
(let [game (util.readjson (filename))]
(each [k v (pairs game)]
(tset game k (lume.map v #(deserialize k (clone $1) game))))
game)
(let [game (util.readjson (filename))]
(if (= game.version 2) (deserialize2 game)
(do (each [k v (pairs game)]
(when (= (type v) :table)
(tset game k (lume.map v #(deserialize k (clone $1) game)))))
game)))
{:tiles [] :portraits [] :font [] :levels []}))
files.game)
(fn files.save [?filename]
(when ?filename (set files.filename ?filename))
(let [game {}]
(each [k v (pairs files.game)]
(tset game k (lume.map v #(serialize k (clone $1) files.game))))
(let [game (serialize2 files.game)]
(set game.version 2)
(util.writejson (filename) game)))
(fn new-cache [game key]
(let [spritegen (match key
:font tiledraw.char-to-sprite
:brushes tiledraw.char-to-sprite
:portraits tiledraw.portrait-to-sprite
_ tiledraw.tile-to-sprite)
(let [tiledraw (require :editor.tiledraw)
tiles (require :game.tiles)
spritegen (tiledraw.spritegen-for-style key)
gfx (. game key)]
(tiledraw.TileCache gfx spritegen)))
(fn files.cache [key]
(when (= (. files.game key) nil)
(tset files.game key []))
(when (= (?. files :tilecaches key) nil)
(util.nested-tset files [:tilecaches key] (new-cache files.game key)))
(. files.tilecaches key))
@ -86,6 +101,12 @@
(fn files.module []
(or files.game.module (: (filename) :match "^[^/]+")))
(fn files.platform [] (or files.game.platform :ii))
(fn files.default-platform-method [cls module-prefix method default]
(tset cls method (fn [...] (let [f (. (require (.. module-prefix :. (files.platform))) method)] (if f (f ...) (default ...))))))
(fn files.platform-methods [cls module-prefix ...]
(each [_ key (ipairs [...])] (files.default-platform-method cls module-prefix key #nil)))
(when (= files.game nil)
(files.load))

View file

@ -2,6 +2,29 @@
(local lume (require :lib.lume))
(local files (require :game.files))
(local platforms {
:ii {:mapw 20 :maph 12 :tilew 14 :tileh 16 :editw 16
:font {:tilew 7 :editw 8 :tileh 8}
:brushes {:tilew 7 :editw 8 :tileh 8}
:portraits {:tilew 28 :editw 32 :tileh 32}}
:iigs {:mapw 26 :maph 16 :tilew 12 :tileh 12
:layers [{:style :tiles} {:style :iso :x 6 :y 6} {:style :iso :x 6}]
:yoffsets [0 6 0]
:iso {:mapw 12 :maph 28 :tilew 24 :tileh 32 :xstagger 12 :ystagger 6}
:font {:tilew 8 :tileh 8}
:brushes {:tilew 8 :tileh 8}
:portraits {:tilew 32 :tileh 32}}
})
(fn dimensions [] (. platforms (files.platform)))
(fn style [name] (or (. (dimensions) name) (dimensions)))
(fn tile-styles [include-details]
(let [dim (dimensions)
styles {:tiles dim}]
(each [_ {:style layer} (ipairs (or dim.layers []))]
(when (not= layer :tiles) (tset styles layer (. dim layer))))
(if include-details styles (lume.keys styles))))
(fn flags [] (or files.game.tileflags [:walkable]))
(fn flag-to-bit []
(collect [iflag flag (ipairs (flags))] (values flag (bit.lshift 1 (- iflag 1)))))
@ -55,5 +78,5 @@
(find-itile tiles label (+ itile 1))))
{: appendtiles : appendgfx : append-portraitwords : flags : flag-to-bit : find-itile
: encode-yx : encode-itile : decode-itile}
: encode-yx : encode-itile : decode-itile : dimensions : tile-styles : style}

30
inspector/debug.fnl Normal file
View file

@ -0,0 +1,30 @@
(local core (require :core))
(local style (require :core.style))
(local util (require :lib.util))
(local repl (require :editor.repl))
(local ReplView (require :editor.replview))
(local module (util.hot-table ...))
(fn find-existing-inspector-window [name]
(var result nil)
(each [_ view (ipairs (core.root_view.root_node:get_children)) :until result]
(when (= view.inspector-name name)
(set result view)))
result)
(fn create-inspector-window [name ?value]
(let [node (core.root_view:get_active_node)
conn (repl.new)
view (ReplView conn)]
(set view.inspector-name name)
(set view.title name)
(view:append {:draw (fn [_ _ x y] (renderer.draw_text style.font name x y style.text) (+ (style.font:get_height) style.padding.y))})
(view:append (repl.mk-result [?value]))
(node:add_view view)))
(lambda module.show [name ?value]
(when (= (find-existing-inspector-window name) nil)
(create-inspector-window name ?value)))
module.hot

View file

@ -1,7 +1,7 @@
(local util (require :lib.util))
(local style (require :core.style))
(local {: defmulti : defmethod} (util.require :lib.multimethod))
(local {: textbutton} (util.require :editor.imstate))
(local {: textbutton : label : under : right-of : reform : group-wrapper } (util.require :editor.imgui))
(local inspector (util.hot-table ...))
@ -15,7 +15,7 @@
best-inspector)
(set inspector.inspect
(defmulti (fn [state value view x y w]
(defmulti (fn [form state value]
(when (= state.inspector nil)
(set state.inspector (inspector.best-inspector value)))
state.inspector) :inspect ...))
@ -26,43 +26,29 @@
(tset inspector.inspectors name {: predicate : priority :inspector inspect-func})
(defmethod inspector.inspect name inspect-func))
(fn inspector.text-height [text ?font]
(let [font (or ?font style.code_font)
(_ newlines) (text:gsub "\n" "\n")]
(* (font:get_height) (+ newlines 1))))
(fn inspector.draw-text [font text x y color]
(renderer.draw_text font text x y color)
(inspector.text-height text))
(inspector.register :default 0 #true (fn [state value view x y w]
(inspector.draw-text style.code_font (fv value) x y style.text)))
(inspector.register :default 0 #true (fn [form state value]
(label (reform form {:font style.code_font}) (fv value))))
(inspector.register :table 10
#(and (= (type $1) :table) (not= (next $1) nil))
(fn [state tbl view x y w]
(local font style.code_font)
(var h 0)
; todo: state assumes an .inspector key
; todo: inspector swapping
; todo: edit in place?
(fn get-kstate [tbl k state]
(when (= nil state.keys) (set state.keys {}))
(when (= nil (?. state.keys k))
(util.nested-tset state [:keys k] {:collapsed (= (type (. tbl k)) :table) :children {}}))
(. state.keys k))
(each [k v (pairs tbl)]
(let [kstate (get-kstate tbl k state)
kstr (fv k)
wk (font:get_width kstr)
xoffset (+ wk style.padding.x)
toggle-collapse (textbutton view kstr x (+ y h))
hv (if kstate.collapsed
(inspector.draw-text font "..." (+ x xoffset) (+ y h) style.syntax.comment)
(inspector.inspect kstate.children v view (+ x xoffset) (+ y h) (- w xoffset)))]
(when toggle-collapse (set kstate.collapsed (not kstate.collapsed)))
(set h (+ h hv style.padding.y))))
h))
(fn [form state tbl]
(let [get-kstate (fn [tbl k state]
(when (= nil state.keys) (set state.keys {}))
(when (= nil (?. state.keys k))
(util.nested-tset state [:keys k] {:collapsed (= (type (. tbl k)) :table) :children {}}))
(. state.keys k))
g (group-wrapper form)]
(each [k v (pairs tbl)]
(let [kstate (get-kstate tbl k state)]
; todo: state assumes an .inspector key
; todo: inspector swapping
; todo: edit in place?
(when (g textbutton (under form {:font style.code_font}) (fv k))
(set kstate.collapsed (not kstate.collapsed)))
(if kstate.collapsed
(g label (right-of form {:color style.syntax.comment :into {}}) "...")
(g #(inspector.inspect $...) (right-of form {:into {}}) kstate.children v))
(g))))))
inspector.hot

File diff suppressed because one or more lines are too long

View file

@ -1,5 +1,6 @@
(require "love.event")
(local view (require "lib.fennelview"))
(local fennel (require "lib.fennel"))
(local view fennel.view)
;; This module exists in order to expose stdio over a channel so that it
;; can be used in a non-blocking way from another thread.

View file

@ -9,20 +9,28 @@
(fn lo [v] (bit.band v 0xff))
(fn hi [v] (bit.band (bit.rshift v 8) 0xff))
(fn loword [v] (bit.band v 0xffff))
(fn hiword [v] (bit.band (bit.rshift v 16) 0xffff))
(fn int8-to-bytes [i]
(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)))
(string.char (lo i) (hi i) (lo (bit.rshift i 16))))
(fn int32-to-bytes [i]
(string.char (lo i) (hi i) (lo (bit.rshift i 16)) (hi (bit.rshift i 16))))
(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))))
(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 bytes-to-uint32 [b ?offset]
(local [lo hi] [(bytes-to-uint16 b ?offset) (bytes-to-uint16 b (+ 2 (or ?offset 0)))])
(bit.bor lo (bit.lshift hi 16)))
(fn splice [bytes offset str]
(.. (bytes:sub 1 offset)
@ -111,8 +119,24 @@
(when (not= f nil) (io.close f))
(not= f nil)))
{: 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 : hot-table : nested-tset
(fn pairoff [l]
(fn [_ iprev] (let [i (if iprev (+ iprev 2) 1)]
(when (< i (length l)) (values i (. l i) (. l (+ i 1)))))))
(fn countiter [minmax ?max ?step]
(let [min (if ?max minmax 1)
max (or ?max minmax)
step (or ?step 1)]
(fn [_ iprev]
(let [i (if iprev (+ iprev step) min)]
(when (if (> step 0) (<= i max) (>= i max)) i)))))
(fn condlist [...] (let [l []] (lume.push l ...) l))
(fn prototype [base] (setmetatable {} {:__index base}))
{: int8-to-bytes : int16-to-bytes : int24-to-bytes : int32-to-bytes : bytes-to-uint8 : bytes-to-uint16 : bytes-to-uint24 : bytes-to-uint32
: splice : lo : hi : loword : hiword : condlist : prototype
: reload : hotswap : swappable :require swappable-require : hot-table : nested-tset : pairoff : countiter
: readjson : writejson : file-exists : waitfor : in-coro : multival}

View file

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

View file

@ -23,7 +23,7 @@
(set self.breakpoints {}))
(fn Machine.boot [self]
(when (not self.pid)
(set self.pid (start-mame :apple2e))))
(set self.pid (start-mame :apple2gs))))
(fn Machine.run [self]
(self:boot)
(self:connect))
@ -70,7 +70,7 @@
(var last-addr ?last-addr)
(while (let [state manager.machine.debugger.execution_state
addr (. manager.machine.devices ::maincpu :state :PC :value)]
(not (and (= state :stop) (not= addr ?last-addr))))
(not (and (= state :stop) (not= addr last-addr))))
(when (= :run manager.machine.debugger.execution_state)
(set last-addr nil))
(coroutine.yield))))
@ -141,7 +141,7 @@
(bencode.encode addr-to-bytes)))
(fn Machine.launch [self prg]
(self:eval "(manager.machine:soft_reset)")
(self:eval (string.format "(emu.keypost \"CALL-151\\n %xG\\n\")" (prg:lookup-addr prg.start-symbol))))
(self:eval (string.format "(emu.keypost \"\n\nCALL-151\\n %xG\\n\")" (prg:lookup-addr prg.start-symbol))))
(fn Machine.reboot [self] (self:eval "(manager.machine:hard_reset)"))
(fn Machine.coro-eval [self code ?handlers]
(var result nil)
@ -174,7 +174,7 @@
(self:set-bp addr
#(util.in-coro (fn []
(self:clear-bp addr)
(local hotswap (prg-old:read-hotswap self))
(local hotswap (prg-old:read-hotswap self prg-new))
(prg-new:upload self)
(prg-new:write-hotswap self hotswap)
(self:jump (prg-new:lookup-addr :on-hotswap))

View file

@ -72,7 +72,6 @@
(tset self.active-requests msg-id nil))
:handle
(fn [self response]
(pp response)
(local handlers (self:merge-handlers response))
(each [prop handler (pairs handlers)]
(local idiv (prop:find :/))

153
link/udpdebug.fnl Normal file
View file

@ -0,0 +1,153 @@
(local core (require :core))
(local socket (require :socket))
(local {: int16-to-bytes : int32-to-bytes : bytes-to-uint16 : bytes-to-uint32 : lo : in-coro} (require :lib.util))
(local Ssc (require :ssc))
(import-macros {:sss ! : compile} :ssc.macros)
(local config {
:host "172.24.1.6"
:port 6502
})
{:cmd {
:write 0
:read 1
:eval 2
:pause 3
:ping 4
}
:response {
:ack 0
:data 1
}
:pending {}
:msgid 0
:waiting false
:queue []
:connect
(fn [self ?port ?host]
(when (not self.connection)
(local [port host] [(or ?port config.port) (or ?host config.host)])
(set self.connection (assert (socket.udp)))
(assert (self.connection:setpeername host port))
(self.connection:settimeout 0)
(core.add_thread #(while (self:connected?) (self:receive) (coroutine.yield)) self.connection)))
:connected? (fn [self] (not= self.connection nil))
:disconnect
(fn [self]
(when self.connection
(self.connection:close)
(set self.connection nil)
(set self.pending {})
(set self.queue [])
(set self.waiting false)))
:next-msgid
(fn [self]
(set self.msgid (lo (+ self.msgid 1)))
self.msgid)
:send
(fn [self cmd ?data ?callback]
(self:enqueue
#(let [msgid (self:next-msgid)
msg (.. (string.char msgid cmd) (or ?data ""))]
(print "sending" msgid cmd (length msg))
(when ?callback
(tset self.pending msgid ?callback)
(set self.waiting true))
(self.connection:send msg))))
:receive
(fn [self]
(when self.connection
(let [data (self.connection:receive)]
(when data
(let [msgid (string.byte (data:sub 1 1))
cmd (string.byte (data:sub 2 2))
pendingfn (. self.pending msgid)]
(print "recieved" msgid cmd)
(when pendingfn
(tset self.pending msgid nil)
(pendingfn self cmd (data:sub 3)))
(set self.waiting false)))
(when (and (not self.waiting) (> (length self.queue) 0))
(let [f (. self.queue 1)]
(table.remove self.queue 1)
(f))))))
:enqueue (fn [self f] (table.insert self.queue f))
:eval (fn [self c {: parent : org : ignore-result}]
(let [parent (or parent (require :ssc.iigs.u2-debug))
ssc (Ssc {: parent})
org (or org (parent.prg:lookup-addr :u2-debug-buffer))]
(compile ssc
(org [org])
(fn do-the-thing () [c]))
(ssc:assemble)
(if (not ignore-result)
(let [(_ data) (self:coro-send self.cmd.eval (. ssc.prg.org-to-block org :bytes))]
{:word (bytes-to-uint16 data) :long (bytes-to-uint32 data 2)})
(self:send self.cmd.eval (. ssc.prg.org-to-block org :bytes)))))
:jump (fn [self addr] (self:eval (! (asm (jsl [(tostring addr)]))) {:ignore-result true}))
:coro-send
(fn [self cmd ?data]
(let [coro (coroutine.running)]
(self:send cmd ?data #(coroutine.resume coro $2 $3))
(coroutine.yield)))
:handle-ack (fn [self cmd] (assert (= cmd self.response.ack)))
:split-batches (fn [self blocks max-size]
; just make sure it's legal, not optimal - no need to solve an NP-hard bin-packing problem
(fn add-to-batch [batches iblock size]
(let [batch (. batches (length batches))
block (. blocks iblock)]
(if (= block nil) batches
; must be split into multiple batches
(> block.len max-size)
(do (for [i 0 (- block.len 1) max-size]
(when (and (= i 0) (= (length batch) 0)) (table.remove batches))
(table.insert batches [{:addr (+ block.addr i)
:data (when block.data (block.data:sub (+ i 1) (+ i max-size)))
:len (math.min (- block.len i) max-size)
:offset 1
:append-to-addr block.addr}]))
(add-to-batch batches (+ iblock 1) (if (= (% block.len max-size) 0) max-size (% block.len max-size))))
; we have run off the end of the current batch
(> (+ size block.len) max-size)
(do (table.insert batches [])
(add-to-batch batches iblock 0))
; there is enough space to fit into the current batch
(do (set block.offset (+ size 1))
(table.insert batch block)
(add-to-batch batches (+ iblock 1) (+ size block.len))))))
(add-to-batch [[]] 1 0))
:read-batch (fn [self addr-to-len]
(let [blocks (icollect [addr len (pairs addr-to-len)] {: addr : len})
result {}]
(each [_ batch (ipairs (self:split-batches blocks 1450))]
(let [msg (.. (int16-to-bytes (length batch))
(table.concat (icollect [_ {: addr : len} (ipairs batch)] (.. (int32-to-bytes addr) (int16-to-bytes len)))))
(response data) (self:coro-send self.cmd.read msg)]
(assert (= response self.response.data))
(each [_ {: addr : len : offset : append-to-addr} (ipairs batch)]
(let [read-data (data:sub offset (+ offset len -1))]
(if append-to-addr (tset result append-to-addr (.. (. result append-to-addr) read-data))
(tset result addr read-data))))))
result))
:read (fn [self addr len] (. (self:read-batch {addr len}) addr))
:write-batch (fn [self addr-to-data]
(let [blocks (icollect [addr data (pairs addr-to-data)] {: addr :len (+ (length data) 6) : data})]
(each [_ batch (ipairs (self:split-batches blocks 1450))]
(let [msg (.. (int16-to-bytes (length batch))
(table.concat (icollect [_ {: addr : data} (ipairs batch)] (.. (int32-to-bytes addr) (int16-to-bytes (length data)) data))))]
(print "writing batch of size" (length batch) (length msg))
(self:send self.cmd.write msg self.handle-ack)))))
:write (fn [self addr data] (self:write-batch {addr data}))
:pause (fn [self] (self:send self.cmd.pause (int16-to-bytes 0xffff) self.handle-ack))
:resume (fn [self] (self:send self.cmd.pause (int16-to-bytes 0) self.handle-ack))
:launch (fn [self prg] (self:jump (prg:lookup-addr prg.start-symbol)))
:hotswap
(fn [self prg-old prg-new]
(in-coro (fn []
(self:pause)
(local hotswap (prg-old:read-hotswap self prg-new))
(prg-new:upload self)
(prg-new:write-hotswap self hotswap)
(self:resume))))
}

View file

@ -1,6 +1,7 @@
-- bootstrap the compiler
fennel = require("lib.fennel")
table.insert(package.loaders, fennel.make_searcher())
table.insert(package.loaders, fennel.searcher)
debug.traceback = fennel.traceback
fv = fennel.view
pp = function(x) print(fv(x)) end
lume = require("lib.lume")

1
neutgs/game.json Normal file

File diff suppressed because one or more lines are too long

129
neutgs/init.fnl Normal file
View file

@ -0,0 +1,129 @@
(local Ssc (require :ssc))
(local files (require :game.files))
(local {: pal} (require :editor.tiledraw.iigs))
(local u2-debug (require :ssc.iigs.u2-debug))
(local link (require :link))
(import-macros {:sss ! : compile} :ssc.macros)
(local ssc (Ssc {:parent u2-debug}))
(compile ssc
(require ssc.iigs.bootstub)
(require ssc.iigs.toolbox)
(require ssc.iigs.graphics)
(tooltable toolsets
ToolsetIntegerMath 0x0100
ToolsetText 0x0100
ToolsetQuickDraw 0x0100
ToolsetEventManager 0x0100
5 0x0100 ; desk manager
9 0x0100) ; ADB
(buffer hexbuf (cstr " "))
(fn printnum (num)
(long! (ref hexbuf) (HexIt num))
(WriteCString (far-ref hexbuf)))
(asm event-buffer)
(global word event-what)
(global long event-msg)
(global long event-when)
(global word event-y)
(global word event-x)
(global word event-mod)
(fn wait-for-key ()
(FlushEvents keyDownMask 0)
(while (not (GetNextEvent keyDownMask (far-ref event-buffer)))
(yield)))
(define screen-addr 0xe12000)
(define screen-size 0x9d00)
(compile-sprite tile0 [(. files.game.iso 3 :gfx)] 24 32)
(compile-sprite tile1 [(. files.game.iso 5 :gfx)] 24 32)
(compile-sprite tile2 [(. files.game.iso 11 :gfx)] 24 32)
(compile-sprite tile3 [(. files.game.iso 12 :gfx)] 24 32)
(asm tiles (jmp tile0) (nop) (jmp tile1) (nop) (jmp tile2) (nop) (jmp tile3) (nop))
(form set-palette [(fn [ssc index pal]
(let [addr (+ 0xe19e00 (* index 0x20))
writes (icollect [icolor [r g b] (ipairs pal)]
[[:lda (bit.bor (bit.lshift r 8) (bit.lshift g 4) b)] [:sta (tostring (+ addr (* icolor 2) -2))]])]
(lume.concat [:block] (table.unpack writes))))])
(global word userID)
(fn print-numbers-forever ()
(let (i 0) (while true
(printnum i)
(yield)
(set! i (+ i 1)))))
(form itile-to-tile [(fn [ssc itile]
[:block (ssc:expr-word itile) [:asl] [:asl] [:clc] [:adc #($1:lookup-addr :tiles)]])])
(global word with-shadowing 0)
(fn draw-test-tiles (i)
(when with-shadowing (disable-shadow-writes))
(let (x 0 y 0 screen 0x2000)
(while (< y 26)
(let (tile (itile-to-tile (& (+ x y i) 3)))
(draw-object screen tile))
(set! x (+ x 1))
(if (= x 12)
(do (set! y (+ y 1))
(set! x 0)
(set! screen (+ screen (if (& y 1) [(+ (- 160 (* 11 12)) (* 160 5) 6)]
[(+ (- 160 6 (* 11 12)) (* 160 5))]))))
(set! screen (+ screen 12))))))
(fn draw-test-tiles-forever ()
(let (i 0)
(forever
(draw-test-tiles i)
(yield)
(set! i (+ i 1)))))
(fn debug-task () (forever [(if (= link.name :udpdebug) [:u2-debug-server-poll] [:do])] (yield)))
(far-fn main ()
(new-task (ref debug-task))
(LoadTools (far-ref toolsets))
(set! userID (MMStartUp))
(IMStartUp)
(TextStartUp)
(QDStartUp 0x3100 0 0 userID)
(EMStartUp 0x3000 0 0 320 0 200 userID)
(GrafOn)
(ClearScreen 0)
(let (screen 0x12000) (while (< screen 0x1a000)
(word! screen 0)
(set! screen (+ screen 2))))
(set-palette 0 [pal])
(SetAllSCBs 0)
(enable-shadow-writes)
(draw-test-tiles 0)
(wait-for-key)
(let (tile-task (new-task (ref draw-test-tiles-forever)))
(wait-for-key)
; (set! with-shadowing 1)
; (wait-for-key)
; (set! with-shadowing 2)
; (wait-for-key)
; (set! with-shadowing false)
(reset-task tile-task (ref yield-forever))
(wait-for-key))
(GrafOff)
(EMShutDown)
(QDShutDown)
(TextShutDown)
(IMShutDown)
(MMShutDown userID)))
(ssc:assemble)

View file

@ -2,7 +2,7 @@
(local style (require :core.style))
(local common (require :core.common))
(local View (require :core.view))
(local {: attach-imstate : textbutton} (require :editor.imstate))
(local {: attach-imstate : textbutton} (require :editor.imgui))
(local SlideshowView (View:extend))
(fn SlideshowView.parse [slides]
@ -107,13 +107,10 @@
(fn SlideshowView.render-element [self element y]
(if element.button
(let [(pressed yNext) (textbutton self
element.text
(+ self.position.x (self:justify element (element.font:get_width element.text)))
y
element.font)]
(when pressed (element:button))
(self:next-y element (- yNext y) y))
(let [form {:view self :font element.font
:x (+ self.position.x (self:justify element (element.font:get_width element.text))) : y}]
(when (textbutton form element.text) (element:button))
(self:next-y element form.h y))
element.text
(let [lines (self:word-wrap element)

View file

@ -25,8 +25,9 @@
:justify :left
:lowerPadding 7
:pause-after true})
(fn p [style ?text] (lume.merge style {:pause-after true} (if ?text {:text ?text :style false})))
(fn np [style ?text] (lume.merge style {:pause-after false} (if ?text {:text ?text :style false})))
(fn p [style ?text] (lume.merge style {:pause-after true} (if ?text {:text ?text :style false} {})))
(fn np [style ?text] (lume.merge style {:pause-after false} (if ?text {:text ?text :style false} {})))
(fn bgimg [filename] {:image filename :justify :center :overlay true :alpha 0.3 :topPadding 0})
@ -151,7 +152,7 @@
(openview #(MapEditView) {:pause-after true})
{:target 180 :section "Branching Out"}]
[h "Thanks!"
(openfile :neuttower/level6.fnl {:split :right :line 164})
(openfile :neuttower/level6.fnl {:split :right :line 164})
(np **) "Questions?"
{:topPadding 128}
"Jeremy Penner"

112
ssc/hotswap.fnl Normal file
View file

@ -0,0 +1,112 @@
; hotswap support
(local {: addr-parser} (require :asm.65816))
(local util (require :lib.util))
(local {: bytes-to-uint16 : bytes-to-uint24 : int16-to-bytes : int24-to-bytes} util)
; Hotswap theory:
; The common case is code moving around in memory; even if you are not changing the content of code that
; is currently executing, any changes to anything mean that pointers to that code will need to change.
; If you try not to store pointers in globals (when everything is statically allocated, you should explicitly
; name things, like in Forth) then the main place that persistent pointers to code exist is in call stacks -
; specifically, the values on the stack consumed by "rts" or "rtl". When hotswapping, we need to walk the
; callstack and A. find these values, and B. patch them to their new values. For this, we need to be able to
; map any address that might be returned to from the old program to the new program - we can easily do this
; by generating symbols for each callsite and setting up a reverse lookup table. We _also_ need to know the
; stack layout at the time of each call so that we can find the next link in the chain, and to verify that
; this hasn't changed (if the function has changed enough, then we can't modify it mid-execution).
(fn assert-local-matches [funcname loc-old loc-new]
(each [_ key (ipairs [:type :name :returnaddr])]
(assert (= (. loc-old key) (. loc-new key)) (.. "Stack mismatch when patching " funcname))))
(fn assert-locals-match [funcname locals-old locals-new]
(assert (= (length locals-old) (length locals-new)) (.. "Stack size mismatch when patching " funcname))
(each [iloc loc-old (ipairs locals-old)]
(assert-local-matches funcname loc-old (. locals-new iloc))))
(fn next-callsite-offset [locals]
(var offset 0)
(var start-counting false)
(each [_ loc (ipairs locals)]
(if start-counting (let [size (match loc.type :placeholder 0 :word 2 :long 4)] (set offset (+ offset size)))
loc.returnaddr (set start-counting true)))
offset)
(fn next-callsite-far? [locals]
(var far? false)
(each [_ loc (ipairs locals)]
(when (and loc.returnaddr (= loc.type :long))
(set far? true)))
far?)
(fn read-callsite-addr [stack bank far]
(if far (bytes-to-uint24 stack 1) ; lowest byte (top of stack) is preserved B register
(bit.bor (bytes-to-uint16 stack) (bit.lshift bank 16))))
(fn lookup-callsite [ssc addr]
(if (= addr (- (ssc.prg:lookup-addr :yield-forever) 1))
{:callsite-sym :yield-forever :locals [] :calling :yield-forever :funcname "<base task>"}
(. ssc.addr-to-callsite addr)))
(fn patch-stack [ssc-old ssc-new stack bank far]
(if (= (length stack) 0) stack
; top-of-stack should be a callsite; look it up
(let [callsite-addr (read-callsite-addr stack bank far)
{: callsite-sym : locals : funcname} (assert (lookup-callsite ssc-old callsite-addr)
(.. "Top of stack value " callsite-addr " is not a recognized callsite"))
new-addr (- (ssc-new.prg:lookup-addr callsite-sym) 1)
{:locals new-locals} (lookup-callsite ssc-new new-addr)
new-bank (bit.rshift new-addr 16)
_ (when (not far) (assert (= (bit.band callsite-addr 0xff0000) (bit.band new-addr 0xff0000))
(.. funcname " moved banks from " bank " to " new-bank)))
_ (print (.. "patching " callsite-sym " from " callsite-addr " to " new-addr))
_ (assert-locals-match funcname locals new-locals)
new-top (if far (.. (stack:sub 1 1) (int24-to-bytes new-addr))
(int16-to-bytes new-addr))
iaftertop (if far 5 3)
inextstack (+ iaftertop (next-callsite-offset locals))]
(.. new-top (stack:sub iaftertop (- inextstack 1))
(if (= funcname ssc-old.prg.start-symbol) (stack:sub inextstack) ; stop when we hit the boot-up function
(patch-stack ssc-old ssc-new (stack:sub inextstack) new-bank (next-callsite-far? locals)))))))
(fn split-equally [s size]
(values (fn [s iprev] (let [i (+ iprev 1)
istart (+ (* (- i 1) size) 1)
iend (* i size)]
(when (>= (length s) iend) (values i (s:sub istart iend)))))
s 0))
(fn read-stacks [link ssc]
(let [stack-bounds-addr (ssc.prg:lookup-addr :first-task)
stack-bounds-bytes (link:read stack-bounds-addr 4)
first-task (bytes-to-uint16 stack-bounds-bytes)
last-task (bytes-to-uint16 stack-bounds-bytes 2)
task-size 0x100
read-size (+ (- last-task first-task) task-size)
task-count (/ read-size task-size)
task-bytes (link:read first-task read-size)
sp-offset (addr-parser ssc.TASK-STACK)]
(icollect [_ task (split-equally task-bytes task-size)]
(let [sp-addr (bytes-to-uint16 task sp-offset)
istackstart (bit.band sp-addr 0xff)
stack (task:sub (+ istackstart 2))]
{:sp-addr (+ sp-addr 1) : stack}))))
(fn lookup-yield-bank [ssc] (bit.rshift (ssc.prg:lookup-addr :yield) 16))
(fn filter-nonyielding-stacks [ssc stacks]
(let [yield-bank (lookup-yield-bank ssc)]
(icollect [_ stack (ipairs stacks)]
(let [callsite-addr (read-callsite-addr stack.stack yield-bank false)
callsite (lookup-callsite ssc callsite-addr)
funcname (?. callsite :calling)]
(when (= funcname :yield) stack)))))
(fn hotswap-stacks [link ssc-old ssc-new]
(let [stacks (read-stacks link ssc-old)
yielding-stacks (filter-nonyielding-stacks ssc-old stacks)]
(collect [_ {: sp-addr : stack} (ipairs yielding-stacks)]
(let [(success new-stack) (pcall #(patch-stack ssc-old ssc-new stack (lookup-yield-bank ssc-old) false))]
(if success (values (tostring sp-addr) new-stack)
(error (.. new-stack ": stack at " (string.format "%X" sp-addr))))))))
{: hotswap-stacks}

61
ssc/iigs/bootstub.fnl Normal file
View file

@ -0,0 +1,61 @@
(import-macros {:sss ! : compile} :ssc.macros)
(local link (require :link))
#(compile $1
(start-symbol boot)
(predef-fn boot () void far)
(predef-fn [(or $2 :main)] () void far)
[(when (not= link.name :udpdebug) (! (do ;udpdebug boots into 16-bit mode
(start-symbol boot-8)
(org 0x1000)
(fn boot-8 ()
(asm (clc) (xce) (rep 0x30)) ; disable emulation mode, 16-bit index registers
(boot)
(asm (sec) (xce))) ; re-enter emulation mode
)))]
(org 0x060000)
(require ssc.iigs.toolbox)
(require ssc.task)
(global word BootUserID)
(global long BootHandle-00)
(global long BootHandle-01)
(global long BootHandle-e0)
(global long BootHandle-e1)
(global long BootHandle-06)
(far-fn boot ()
(save-dp-sp 0x0800)
(set-task-base 0x0800) ; space for 8 tasks
(save-6502-stack)
; http://www.1000bit.it/support/manuali/apple/technotes/pdos/tn.pdos.27.html
; When bootstrapping with no OS, we must reserve
(TLStartUp)
(LoadOneTool ToolsetMisc 0x0100)
(MTStartUp)
(set! BootUserID (GetNewID 0x1f00))
(LoadOneTool ToolsetMemoryManager 0x0100)
(set! BootHandle-06 (NewHandle 0xffff BootUserID 0xb017 0x060000))
(set! BootHandle-00 (NewHandle 0xb800 BootUserID 0xb017 0x000800))
(set! BootHandle-01 (NewHandle 0xb800 BootUserID 0xb017 0x010800))
(set! BootHandle-e0 (NewHandle 0x4000 BootUserID 0xb017 0xe02000))
(set! BootHandle-e1 (NewHandle 0x8000 BootUserID 0xb017 0xe12000))
( [(or $2 :main)] )
(DisposeHandle BootHandle-e1)
(DisposeHandle BootHandle-e0)
(DisposeHandle BootHandle-01)
(DisposeHandle BootHandle-00)
(DisposeHandle BootHandle-06)
(DeleteID BootUserID)
(MTShutDown)
(restore-6502-stack)
(restore-dp-sp)))

139
ssc/iigs/graphics.fnl Normal file
View file

@ -0,0 +1,139 @@
; IIgs graphical architecture:
; PREMISE: All small-scale bitmapped graphics are encoded as code that pushes the graphics onto the stack,
; which has been aligned to the appropriate place to draw said graphics.
; Jump tables are stored in the main code segment so that eg. tiles can be easily calculated by index, and
; so we don't have to explicitly pass longs to a regular function.
(import-macros {:sss ! : compile} :ssc.macros)
(local lume (require :lib.lume))
(local {: countiter} (require :lib.util))
; Our bitmap compiler is based on MrSprite - http://brutaldeluxe.fr/products/crossdevtools/mrspritetech/
; sprite is a Lua string, where each byte is made up of two nibbles - the low nibble
; should be a 16-bit value representing the colour, and the high nibble should be
; 0 if the pixel is opaque, or f if the pixel is transparent.
; width should be a multiple of 4.
(fn preprocess-sprite [sprite w h]
; splits up each horizontal line into two kinds of "runs":
; :solid - each word can be directly written to memory; there is no transparency
; :masked - the word at this location must be bitwise ANDed by :mask and ORed by :word
; words containing nothing but transparent pixels are removed.
; Also determines the most frequently-occurring solid words and distributes them
; to registers.
(let [rows [] frequencies {}]
(var word 0)
(var mask 0)
(var isprite 1)
(for [y 0 (- h 1)]
(let [row []]
(var solidrun nil)
(for [x 0 (- w 1)]
(let [b (string.byte (sprite:sub isprite isprite))
pixcolour (bit.band b 0x0f)
pixmask (bit.rshift (bit.band b 0xf0) 4)
pixshift (match (% x 4) 0 4 1 0 2 12 3 8)]
(set word (bit.bor word (bit.lshift pixcolour pixshift)))
(set mask (bit.bor mask (bit.lshift pixmask pixshift)))
(when (= (% x 4) 3)
(when (not= mask 0) (set solidrun nil))
(when (= mask 0) ; fully opaque word
(when (= solidrun nil)
(set solidrun {:run :solid :x (/ (- x 3) 2) :words []})
(table.insert row solidrun))
(table.insert solidrun.words word)
(tset frequencies word (+ (or (. frequencies word) 0) 1)))
(when (and (not= mask 0) (not= mask 0xffff))
(table.insert row {:run :masked :x (/ (- x 3) 2) : word : mask}))
(set word 0)
(set mask 0))
(set isprite (+ isprite 1))))
(table.insert rows row)))
(local top-frequencies (icollect [word freq (pairs frequencies)] {: word : freq}))
(table.sort top-frequencies #(> $1.freq $2.freq))
{: rows
:registers {:x (?. top-frequencies 1 :word)
:y (?. top-frequencies 2 :word)
:d (?. top-frequencies 3 :word)}}))
(fn compile-row [block row registers]
(each [_ run (ipairs row)]
(match run.run
:solid
(let [s-target (+ run.x (* (length run.words) 2) -1)]
(lume.push block [:tsc] [:adc (- s-target registers.s)] [:tcs])
(set registers.s (- run.x 1))
(for [iword (length run.words) 1 -1]
(lume.push block
(match (. run.words iword)
registers.x [:phx]
registers.y [:phy]
registers.d [:phd]
word [:pea word]))))
:masked
(do (var s-offset (- run.x registers.s))
(when (> s-offset 127)
(lume.push block [:tsc] [:adc s-offset] [:tcs])
(set registers.s run.x)
(set s-offset 0))
(lume.push block [:lda s-offset :s] [:and run.mask] [:ora run.word] [:sta s-offset :s])))))
(fn compile-sprite [sprite w h]
(let [{: rows : registers} (preprocess-sprite sprite w h)
block (lume.concat [:block]
(when registers.x [[:ldx registers.x]])
(when registers.y [[:ldy registers.y]])
(when registers.d [[:lda registers.d] [:tcd]]))]
(set registers.s 0)
(each [_ row (ipairs rows)]
(compile-row block row registers)
(set registers.s (- registers.s 160)))
block))
#(compile $1
(fn enable-shadow-writes () (set! (word-at (ref :0xc035)) (& (word-at (ref :0xc035)) 0xfff1)))
(fn disable-shadow-writes () (set! (word-at (ref :0xc035)) (| (word-at (ref :0xc035)) 0x000e)))
; The fastest way to draw any graphics on the IIgs is to map the stack pointer to
; video memory, and use stack-pushing instructions to write values. draw-object
; takes a location in video memory and a pointer to a machine code routine called a "drawfn"
; that performs the drawing
(global word draw-object-saved-stack 0)
(fn draw-object (screen object)
(asm (sei) ; disable interrupts
(lda object) (sta [{:abs #(+ ($1:lookup-addr :draw-object-current-object-jump) 1)}]) ; self-modifying code! rewrite the jump target
(phd) ; save direct page register
(tsc) (sta draw-object-saved-stack) ; save stack
(lda screen 2) ; we offset by 2 because we just pushed a word onto the stack and the compiler doesn't know about it
(tcs) ; drawfns expect the current screen pointer to be stored in the stack register
(lda :0xc068) (ora 0x30) (sta :0xc068) ; move bank 1 to bank 0
(clc) ; clear carry - all drawfns will add to the stack pointer and then walk it back
draw-object-current-object-jump
(jmp draw-object) ; will actually jump to "object"
draw-object-finished (export draw-object-finished)
(lda :0xc068) (and 0xffcf) (sta :0xc068) ; move bank 1 back to bank 1
(lda draw-object-saved-stack) (tcs) ; restore the stack pointer
(pld) ; restore direct page register
(cli))) ; enable interrupts
(macrobarrier drawfn)
(form drawfn [(lambda [ssc name ...]
(let [expr (lume.concat [:do ...] [[:asm [:jmp :draw-object-finished]]])]
(ssc:define-fn name nil #(do
(local fname (.. "<drawfn " name ">"))
(local asm (ssc:expr-poly expr))
(ssc:expr-poly [:form name (fn [ssc] (assert (= ssc.locals nil) (.. name " must be called from a drawfn")) [:jmp fname])])
(ssc:expr-poly [:define name [:ref fname]])
(ssc.org:append fname asm)))))])
(drawfn pei-slam-tile
(asm (tsc) (tcd) (adc 7) (tcs)
[(lume.concat [:block] (icollect [_ (countiter 16)]
[(! block (pei (:d6)) (pei (:d4)) (pei (:d2)) (pei (:d0))
(tsc) (adc 161) (tcd) (adc 7) (tcs))]))]))
(drawfn pei-slam-scanline
(asm (tsc) (tcd) (adc 159) (tcs)
[(lume.concat [:block] (icollect [offset (countiter 158 0 -2)] [:pei [(.. :d offset)]]))]))
(form compile-sprite [(lambda [ssc name sprite w h] (ssc:expr-poly [:drawfn name [:asm (compile-sprite sprite w h)]]))])
)

458
ssc/iigs/toolbox.fnl Normal file
View file

@ -0,0 +1,458 @@
(import-macros {:sss ! : compile} :ssc.macros)
(local lume (require :lib.lume))
(local util (require :lib.util))
(local {: pairoff} util)
#(compile $1 (do
(form def-toolbox [
(fn [ssc cmd name args return-type]
(let [call (fn [ssc ...]
(let [arg-count (select :# ...)
expected-arg-count (length args)
expected-resultptr (= (type return-type) :number)
expected-arg-count (if expected-resultptr (+ expected-arg-count 1) expected-arg-count)
resultptr (when expected-resultptr (select expected-arg-count ...))
error-handler (when (= arg-count (+ expected-arg-count 1)) (select (+ expected-arg-count 1) ...))
expected-arg-count (if error-handler (+ expected-arg-count 1) expected-arg-count)
block [:block]
iloc-resultptr (do (assert (= arg-count expected-arg-count) (.. name " expected " expected-arg-count " args, got " (fv [...])))
(when resultptr
(lume.push block (ssc:push nil resultptr :word))
(length ssc.locals)))]
(for [_ 1 (match return-type :void 0 :word 1 :long 2 _ return-type)]
(lume.push block (ssc:push nil nil :register)))
(each [_ push (ipairs (ssc:push-arguments (ssc:parse-parameters args) (lume.slice [...] 1 (length args))))]
(lume.push block push))
(lume.push block [:ldx cmd] [:jsr :0xe10000])
(ssc:was-dropped (length args))
(when error-handler
(lume.push block [:bcc :-no-error-]
(ssc:push :error nil :register) (ssc:expr-poly error-handler) (ssc:drop :error)
:-no-error-))
(match return-type
:void nil
:word (lume.push block (ssc:pop) nil)
:long (lume.push block (ssc:pop) [:sta ssc.LONG_LO] (ssc:pop) [:sta ssc.LONG_HI])
_ (do (lume.push block [:ldy 0])
(for [i 1 return-type]
(lume.push block (ssc:pop) [:sta [(ssc:local-offset iloc-resultptr) :s] :y])
(when (< i return-type) (lume.push block [:iny] [:iny])))
(lume.push block (ssc:drop))))
(values block (if (= (type return-type) :string) return-type :void))))]
(ssc:expr-poly [:form name call])))])
(form tooltable [(fn [ssc name ...]
(ssc.org:append name [:dw (/ (select :# ...) 2)])
(each [_ toolset-id version (pairoff [...])]
(ssc.org:append [:dw (match (type toolset-id) :number toolset-id :string (. ssc.constants toolset-id))]
[:dw version])))])
(define ToolsetToolLocator 0x01)
(def-toolbox 0x0201 TLStartUp () void)
(def-toolbox 0x0301 TLShutDown () void)
(def-toolbox 0x0401 TLVersion () word)
(def-toolbox 0x0b01 GetFuncPtr (userOrSystem funcNumTsNum) long)
(def-toolbox 0x0f01 LoadOneTool (toolNumber minVersion) void)
(def-toolbox 0x0e01 LoadTools ((long toolTablePtr)) void)
(def-toolbox 0x1501 MessageCenter (action type (long messageHandle)) void)
(def-toolbox 0x1401 RestoreTextState ((long stateHandle)) void)
(def-toolbox 0x1301 SaveTextState () long)
(def-toolbox 0x1101 TLMountVolume (whereX whereY (long line1ptr) (long line2ptr) (long but1ptr) (long but2ptr)) word)
(def-toolbox 0x1201 TLTextMountVolume ((long line1Ptr) (long line2Ptr) (long button1Ptr) (long button2Ptr)) word)
(def-toolbox 0x1001 UnloadOneTool (toolNumber) void)
(define ToolsetIntegerMath 0x0b)
(def-toolbox 0x020b IMStartUp () void)
(def-toolbox 0x030b IMShutDown () void)
(def-toolbox 0x040b IMVersion () word)
(def-toolbox 0x060b IMStatus () word)
(def-toolbox 0x280b Dec2Int ((long strPtr) strLength signedFlag) word)
(def-toolbox 0x290b Dec2Long ((long strPtr) strLength signedFlag) long)
(def-toolbox 0x1c0b Fix2Frac ((long fixedValue)) long)
(def-toolbox 0x1b0b Fix2Long ((long fixedValue)) long)
(def-toolbox 0x1e0b Fix2X ((long fixedValue) (long extendPtr)) void)
(def-toolbox 0x170b FixATan2 ((long input1) (long input2)) long)
(def-toolbox 0x110b FixDiv ((long dividend) (long divisor)) long)
(def-toolbox 0x0f0b FixMul ((long multiplicand) (long multiplier)) long)
(def-toolbox 0x0e0b FixRatio (numerator denominator) long)
(def-toolbox 0x130b FixRound ((long fixedValue)) word)
(def-toolbox 0x1d0b Frac2Fix ((long fracValue)) long)
(def-toolbox 0x1f0b Frac2X ((long fracValue) (long extendPtr)) void)
(def-toolbox 0x150b FracCos ((long angle)) long)
(def-toolbox 0x120b FracDiv ((long dividend) (long divisor)) long)
(def-toolbox 0x100b FracMul ((long multiplicand) (long multiplier)) long)
(def-toolbox 0x160b FracSin ((long angle)) long)
(def-toolbox 0x140b FracSqrt ((long fracValue)) long)
(def-toolbox 0x240b Hex2Int ((long strPtr) strLength) word)
(def-toolbox 0x250b Hex2Long ((long strPtr) strLength) long)
(def-toolbox 0x2a0b HexIt (intValue) long)
(def-toolbox 0x180b HiWord ((long longValue)) word)
(def-toolbox 0x260b Int2Dec (wordValue (long strPtr) strLength signedFlag) void)
(def-toolbox 0x220b Int2Hex (intValue (long strPtr) strLength) void)
(def-toolbox 0x270b Long2Dec ((long longValue) (long strPtr) strLength signedFlag) void)
(def-toolbox 0x1a0b Long2Fix ((long longIntValue)) long)
(def-toolbox 0x230b Long2Hex ((long longValue) (long strPtr) strLength) void)
(def-toolbox 0x0d0b LongDivide ((long dividend) (long divisor)) 4) ; -> long remainder, long quotient
(def-toolbox 0x0c0b LongMul ((long multiplicand) (long multiplier)) 4) ; -> long msResult, long lsResult
(def-toolbox 0x190b LoWord ((long longValue)) word)
(def-toolbox 0x090b Multiply (multiplicand multiplier) long)
(def-toolbox 0x0a0b SDivide (dividend divisor) long) ; -> word remainder, word quotient
(def-toolbox 0x0b0b UDivide (dividend divisor) long) ; -> word remainder, word quotient
(def-toolbox 0x200b X2Fix ((long extendPtr)) long)
(def-toolbox 0x210b X2Frac ((long extendPtr)) long)
(define ToolsetMemoryManager 0x02)
(def-toolbox 0x0202 MMStartUp () word)
(def-toolbox 0x0302 MMShutDown (userID) void)
(def-toolbox 0x0402 MMVersion () word)
(def-toolbox 0x0602 MMStatus () word)
(def-toolbox 0x2b02 BlockMove ((long sourcePtr) (long destPtr) (long count)) void)
(def-toolbox 0x1e02 CheckHandle ((long theHandle)) void)
(def-toolbox 0x1f02 CompactMem () void)
(def-toolbox 0x1102 DisposeAll (userID) void)
(def-toolbox 0x1002 DisposeHandle ((long theHandle)) void)
(def-toolbox 0x1a02 FindHandle ((long locationPtr)) long)
(def-toolbox 0x1b02 FreeMem () long)
(def-toolbox 0x1802 GetHandleSize ((long theHandle)) long)
(def-toolbox 0x2a02 HandToHand ((long sourceHandle) (long destHandle) (long count)) void)
(def-toolbox 0x2902 HandToPtr ((long sourceHandle) (long destPtr) (long count)) void)
(def-toolbox 0x2002 HLock ((long theHandle)) void)
(def-toolbox 0x2102 HLockAll (userID) void)
(def-toolbox 0x2202 HUnlock ((long theHandle)) void)
(def-toolbox 0x2302 HUnlockAll (userID) void)
(def-toolbox 0x1c02 MaxBlock () long)
(def-toolbox 0x0902 NewHandle ((long blockSize) userID attributes (long locationPtr)) long)
(def-toolbox 0x2802 PtrToHand ((long sourcePtr) (long destHandle) (long count)) void)
(def-toolbox 0x1302 PurgeAll (userID) void)
(def-toolbox 0x1202 PurgeHandle ((long theHandle)) void)
(def-toolbox 0x0a02 ReAllocHandle ((long blockSize) userID attributes (long locationPtr) (long theHandle)) void)
(def-toolbox 0x0b02 RestoreHandle ((long theHandle)) void)
(def-toolbox 0x1902 SetHandleSize ((long newSize) (long theHandle)) void)
(def-toolbox 0x2402 SetPurge ((long theHandle)) word)
(def-toolbox 0x2502 SetPurgeAll (userID newPurgeLevel) void)
(def-toolbox 0x1d02 TotalMem () long)
(define ToolsetText 0x0c)
(def-toolbox 0x020c TextStartUp () void)
(def-toolbox 0x030c TextShutDown () void)
(def-toolbox 0x040c TextVersion () word)
(def-toolbox 0x060c TextStatus () word) ; -> activeFlag
(def-toolbox 0x160c CtlTextDev (deviceNum controlCode) void)
(def-toolbox 0x1f0c ErrWriteBlock ((long textPtr) offset count) void)
(def-toolbox 0x190c ErrWriteChar (theChar) void)
(def-toolbox 0x210c ErrWriteCString ((long cStrPtr)) void)
(def-toolbox 0x1b0c ErrWriteLine ((long strPtr)) void)
(def-toolbox 0x1d0c ErrWriteString ((long strPtr)) void)
(def-toolbox 0x0e0c GetErrGlobals () long) ; -> word andMask, word orMask
(def-toolbox 0x140c GetErrorDevice () 3) ; -> word deviceType, long ptrOrSlot
(def-toolbox 0x0c0c GetInGlobals () long) ; -> word andMask, word orMask
(def-toolbox 0x120c GetInputDevice () 3) ; -> word deviceType, long ptrOrSlot
(def-toolbox 0x0d0c GetOutGlobals () long) ; -> word andMask, word orMask
(def-toolbox 0x130c GetOutputDevice () 3) ; -> word deviceType, long ptrOrSlot
(def-toolbox 0x150c InitTextDev (deviceNum) void)
(def-toolbox 0x220c ReadChar (echoFlag) word)
(def-toolbox 0x240c ReadLine ((long bufferPtr) maxCount eolChar echoFlag) word)
(def-toolbox 0x0b0c SetErrGlobals (andMask orMask) void)
(def-toolbox 0x110c SetErrorDevice (deviceType (long ptrOrSlot)) void)
(def-toolbox 0x090c SetInGlobals (andMask orMask) void)
(def-toolbox 0x0f0c SetInputDevice (deviceType (long ptrOrSlot)) void)
(def-toolbox 0x0a0c SetOutGlobals (andMask orMask) void)
(def-toolbox 0x100c SetOutputDevice (deviceType ptrOrSlot) void)
(def-toolbox 0x170c StatusTextDev (deviceNum requestCode) void)
(def-toolbox 0x230c TextReadBlock ((long bufferPtr) offset blockSize echoFlag) void)
(def-toolbox 0x1e0c TextWriteBlock ((long textPtr) offset count) void)
(def-toolbox 0x180c WriteChar (theChar) void)
(def-toolbox 0x200c WriteCString ((long cStrPtr)) void) ; ptr cStrPtr
(def-toolbox 0x1a0c WriteLine ((long strPtr)) void)
(def-toolbox 0x1c0c WriteString ((long strPtr)) void)
(define ToolsetMisc 0x03)
(def-toolbox 0x0203 MTStartUp () void)
(def-toolbox 0x0303 MTShutDown () void)
(def-toolbox 0x0403 MTVersion () word)
(def-toolbox 0x0603 MTStatus () word)
(def-toolbox 0x0903 WriteBRam ((long bufferPtr)) void)
(def-toolbox 0x0a03 ReadBRam ((long bufferPTr)) void)
(def-toolbox 0x0b03 WriteBParam (theData paramRefNum) void)
(def-toolbox 0x0c03 ReadBParam (paramRefNum) word)
(def-toolbox 0x0d03 ReadTimeHex () 4) ; -> bytes: weekDay, null, month, day, curYear, hour, minute, second
(def-toolbox 0x0e03 WriteTimeHex (month-day curYear-hour mintue-second) void)
(def-toolbox 0x0f03 ReadAsciiTime ((long bufferPtr)) void)
(def-toolbox 0x2403 FWEntry (aRegValue xRegValue yRegValue eModeEntryPt) 4) ; words: status, aRegExit, xRegExit, yRegExit
(def-toolbox 0x1603 GetAddr (refNum) long)
(def-toolbox 0x2503 GetTick () long)
(def-toolbox 0x2904 GetIRQEnable () word)
(def-toolbox 0x2303 IntSource (srcRefNum) void)
(def-toolbox 0x1c03 ClampMouse (xMinCLamp xMaxClamp yMinClamp yMaxClamp) void)
(def-toolbox 0x1b03 ClearMouse () void)
(def-toolbox 0x1d03 GetMouseClamp () 4) ; words: xMinCLamp, xMaxClamp, yMinClamp, yMaxClamp
(def-toolbox 0x1a03 HomeMouse () void)
(def-toolbox 0x1803 InitMouse (mouseSlot) void)
(def-toolbox 0x1e03 PosMouse (xPos yPos) void)
(def-toolbox 0x1704 ReadMouse () 3) ; xPosition, yPosition, byte status, byte mode
(def-toolbox 0x1f03 ServeMouse () word)
(def-toolbox 0x1903 SetMouse (mouseMode) void)
(def-toolbox 0x2a03 SetAbsClamp (xMinClamp xMaxClamp yMinClamp yMaxClamp) void)
(def-toolbox 0x2b03 GetAbsClamp () 4) ; xMinClamp xMaxClamp yMinClamp yMaxClamp
(def-toolbox 0x2603 PackBytes ((long startHandle) (long sizePtr) (long bufferPtr) bufferSize) word)
(def-toolbox 0x2703 UnPackBytes ((long bufferPtr) bufferSize (long startHandle) (long sizePtr)) word)
(def-toolbox 0x2803 Munger ((long destPtr) (long destLenPtr) (long targPtr) targLEn (long replPtr) replLen (long padPtr)) word)
(def-toolbox 0x1203 SetHeartBeat ((long taskPtr)) void)
(def-toolbox 0x1303 DelHeartBeat ((long taskPtr)) void)
(def-toolbox 0x1403 ClrHeartBeat () void)
(def-toolbox 0x2c03 SysBeep () void)
(def-toolbox 0x1503 SysFailMgr (errorCode (long strPtr)) void)
(def-toolbox 0x2003 GetNewID (idTag) word)
(def-toolbox 0x2103 DeleteID (idTag) void)
(def-toolbox 0x2203 StatusID (idTag) void)
(def-toolbox 0x1003 SetVector (vectorRefNum (long vectorPtr)) void)
(def-toolbox 0x1103 GetVector (vectorRefNum) long)
(define ToolsetEventManager 0x06)
(define nullEvt 0)
(define mouseDownEvt 1)
(define mouseUpEvt 2)
(define keyDownEvt 3)
(define autoKeyEvt 5)
(define updateEvt 6)
(define activeFlag 0x0001)
(define changeFlag 0x0002)
(define btn1State 0x0040)
(define btn0State 0x0080)
(define appleKey 0x0100)
(define shiftKey 0x0200)
(define capsLock 0x0400)
(define optionKey 0x0800)
(define controlKey 0x1000)
(define keyPad 0x2000)
(define mDownMask 0x0002)
(define mUpMask 0x0004)
(define keyDownMask 0x0008)
(define autoKeyMask 0x0020)
(define updateMask 0x0040)
(def-toolbox 0x0206 EMStartUp (dPageAddr queueSize xMinClamp xMaxClamp yMinClamp yMaxClamp userID) void)
(def-toolbox 0x0306 EMShutDown () void)
(def-toolbox 0x0406 EMVersion () word)
(def-toolbox 0x0606 EMStatus () word)
(def-toolbox 0x0d06 Button (buttonNum) word)
(def-toolbox 0x0b06 EventAvail (eventMask (long eventPtr)) word)
(def-toolbox 0x1506 FlushEvents (eventMask stopMask) word)
(def-toolbox 0x1206 GetCaretTime () long)
(def-toolbox 0x1106 GetDblTime () long)
(def-toolbox 0x0c06 GetMouse ((long mouseLocPtr)) void)
(def-toolbox 0x0a06 GetNextEvent (eventMask (long eventPtr)) word)
(def-toolbox 0x1606 GetOSEvent (eventMask (long eventPtr)) word)
(def-toolbox 0x1706 OSEventAvail (eventMask (long eventPtr)) word)
(def-toolbox 0x1406 PostEvent (eventCode (long eventMsg)) word)
(def-toolbox 0x1806 SetEventMask (sysEventMask) void)
(def-toolbox 0x0e06 StillDown (buttonNum) word)
(def-toolbox 0x1006 TickCount () long)
(def-toolbox 0x0f06 WaitMouseUp (buttonNum) word)
(define ToolsetQuickDraw 0x04)
(def-toolbox 0x0204 QDStartUp (dPageAddr masterSCB maxWidth userID) void)
(def-toolbox 0x0304 QDShutDown () void)
(def-toolbox 0x0404 QDVersion () word)
(def-toolbox 0x0604 QDStatus () word)
(def-toolbox 0x8004 AddPt ((long srcPtPtr) (long destPtPtr)) void)
(def-toolbox 0xac04 CharBounds (theChar (long resultPtr)) void)
(def-toolbox 0xa804 CharWidth (theChar) word)
(def-toolbox 0x1504 ClearScreen (colorWord) void)
(def-toolbox 0x2604 ClipRect ((long rectPtr)) void)
(def-toolbox 0xc204 ClosePoly () void)
(def-toolbox 0x1a04 ClosePort ((long portPtr)) void)
(def-toolbox 0x6e04 CloseReg ((long rgnHandle)) void)
(def-toolbox 0x6904 CopyRgn ((long srcRgnHandle) (long dstRgnHandle)) void)
(def-toolbox 0xae04 CStringBounds ((long cStringPtr) (long resultPtr)) void)
(def-toolbox 0xaa04 CStringWidth ((long cStringPtr)) word)
(def-toolbox 0x7304 DiffRgn ((long rgn1Handle) (long rgn2Handle) (long diffRgnHandle)) void)
(def-toolbox 0x6804 DisposeRgn ((long rgnHandle)) void)
(def-toolbox 0xa404 DrawChar (theChar) void)
(def-toolbox 0xa604 DrawCString ((long cStringPtr)) void)
(def-toolbox 0xa504 DrawString ((long stringPtr)) void)
(def-toolbox 0xa704 DrawText ((long textPtr) textLength) void)
(def-toolbox 0x7804 EmptyRgn ((long rgnHandle)) word)
(def-toolbox 0x8304 EqualPt ((long point1Ptr) (long point2Ptr)) word)
(def-toolbox 0x5104 EqualRect ((long rect1Ptr) (long rect2Ptr)) word)
(def-toolbox 0x7704 EqualRgn ((long rgn1Handle) (long rgn2Handle)) word)
(def-toolbox 0x6404 EraseArc ((long rectPtr) startAngle arcAngle) void)
(def-toolbox 0x5a04 EraseOval ((long rectPtr)) void)
(def-toolbox 0xbe04 ErasePoly ((long polyHandle)) void)
(def-toolbox 0x5504 EraseRect ((long rectPtr)) void)
(def-toolbox 0x7b04 EraseRgn ((long rgnHandle)) void)
(def-toolbox 0x5f04 EraseRRect ((long rectPtr) ovalWidth ovalHeight) void)
(def-toolbox 0x6604 FillArc ((long rectPtr) startAngle arcAngle (long patternPtr)) void)
(def-toolbox 0x5c04 FillOval ((long rectPtr) (long patternPtr)) void)
(def-toolbox 0xc004 FillPoly ((long polyHandle) (long patternPtr)) void)
(def-toolbox 0x5704 FillRect ((long rectPtr) (long patternPtr)) void)
(def-toolbox 0x7d04 FillRgn ((long rgnHandle) (long patternPtr)) void)
(def-toolbox 0x6104 FillRRect ((long rectPtr) ovalWidth ovalHeight (long patternPtr)) void)
(def-toolbox 0xcc04 ForceBufDims (maxWidth maxFontHeight maxFBRExtent) void)
(def-toolbox 0x6204 FrameArc ((long rectPtr) startAngle arcAngle) void)
(def-toolbox 0x5804 FrameOval ((long rectPtr)) void)
(def-toolbox 0xbc04 FramePoly ((long polyHandle)) void)
(def-toolbox 0x5304 FrameRect ((long rectPtr)) void)
(def-toolbox 0x7904 FrameRgn ((long rgnHandle)) void)
(def-toolbox 0x5d04 FrameRRect ((long rectPtr) ovalWidth ovalHeight) void)
(def-toolbox 0x0904 GetAddress (tableID) long)
(def-toolbox 0xb104 GetArcRot () word)
(def-toolbox 0xa304 GetBackColor () word)
(def-toolbox 0x3504 GetBackPat ((long patternPtr)) void)
(def-toolbox 0xd504 GetCharExtra () long)
(def-toolbox 0x2504 GetClip ((long rgnHandle)) void)
(def-toolbox 0xc704 GetClipHandle () long)
(def-toolbox 0x1104 GetColorEntry (tableNumber entryNumber) word)
(def-toolbox 0x0f04 GetColorTable (tableNumber (long destTablePtr)) void)
(def-toolbox 0x8f04 GetCursorAdr () long)
(def-toolbox 0xcf04 GetFGSize () word)
(def-toolbox 0x9504 GetFont () long)
(def-toolbox 0x9904 GetFontFlags () word)
(def-toolbox 0x9704 GetFontGlobals ((long fgRecPtr)) void)
(def-toolbox 0xd104 GetFontID () long)
(def-toolbox 0x9604 GetFontInfo ((long fontInfoRecPtr)) void)
(def-toolbox 0xd904 GetFontLore ((long recordPtr) recordSize) word)
(def-toolbox 0xa104 GetForeColor () word)
(def-toolbox 0x4504 GetGrafProcs () long)
(def-toolbox 0x1704 GetMasterSCB () word)
(def-toolbox 0x2904 GetPen () long)
(def-toolbox 0x3304 GetPenMask ((long maskPtr)) void)
(def-toolbox 0x2f04 GetPenMode () word)
(def-toolbox 0x3104 GetPenPat ((long patternPtr)) void)
(def-toolbox 0x2d04 GetPenSize ((long pointPtr)) void)
(def-toolbox 0x2b04 GetPenState ((long penStatePtr)) void)
(def-toolbox 0x3f04 GetPicSave () long)
(def-toolbox 0x8804 GetPixel (h v) word)
(def-toolbox 0x4304 GetPolySave () long)
(def-toolbox 0x1c04 GetPort () long)
(def-toolbox 0x1e04 GetPortLoc ((long locInfoPtr)) void)
(def-toolbox 0x2004 GetPortRect ((long rectPtr)) void)
(def-toolbox 0x4104 GetRgnSave () long)
(def-toolbox 0xd804 GetRomFont ((long recordPtr)) void)
(def-toolbox 0x1304 GetSCB (scanLine) word)
(def-toolbox 0x9f04 GetSpaceExtra () long)
(def-toolbox 0x0c04 GetStandardSCB () word)
(def-toolbox 0x4904 GetSysField () long)
(def-toolbox 0xb304 GetSysFont () long)
(def-toolbox 0x9b04 GetTextFace () word)
(def-toolbox 0x9d04 GetTextMode () word)
(def-toolbox 0xd304 GetTextSize () word)
(def-toolbox 0x4704 GetUserField () long)
(def-toolbox 0xc904 GetVisHandle () long)
(def-toolbox 0xb504 GetVisRgn ((long rgnHandle)) void)
(def-toolbox 0x8504 GlobalToLocal ((long pointPtr)) void)
(def-toolbox 0x0b04 GrafOff () void)
(def-toolbox 0x0a04 GrafOn () void)
(def-toolbox 0x9004 HideCursor () void)
(def-toolbox 0x2704 HidePen () void)
(def-toolbox 0xd704 InflateTextBuffer (newWidth newHeight) void)
(def-toolbox 0x0d04 InitColorTable ((long tablePtr)) void)
(def-toolbox 0xca04 InitCursor () void)
(def-toolbox 0x1904 InitPort ((long portPtr)) void)
(def-toolbox 0x4c04 InsetRect ((long rectPtr) dH dV) void)
(def-toolbox 0x7004 InsetRgn ((long rgnHandle) dH dV) void)
(def-toolbox 0x6504 InvertArc ((long rectPtr) startAngle arcAngle) void)
(def-toolbox 0x5b04 InvertOval ((long rectPtr)) void)
(def-toolbox 0xbf04 InvertPoly ((long polyHandle)) void)
(def-toolbox 0x5604 InvertRect ((long rectPtr)) void)
(def-toolbox 0x7c04 InvertRgn ((long rgnHandle)) void)
(def-toolbox 0x6004 InvertRRect ((long rectPtr) ovalWidth ovalHeight) void)
(def-toolbox 0xc304 KillPoly ((long polyHandle)) void)
(def-toolbox 0x3d04 Line (dH dV) void)
(def-toolbox 0x3c04 LineTo (h v) void)
(def-toolbox 0x8404 LocalToGlobal ((long pointPtr)) void)
(def-toolbox 0xc504 MapPoly ((long polyHandle) (long srcRectPtr) (long destRectPtr)) void)
(def-toolbox 0x8a04 MapPt ((long pointPtr) (long srcRectPtr) (long destRectPtr)) void)
(def-toolbox 0x8b04 MapRect ((long rectPtr) (long srcRectPtr) (long destRectPtr)) void)
(def-toolbox 0x8c04 MapRgn ((long mapRgnHandle) (long srcRectPtr) (long destRectPtr)) void)
(def-toolbox 0x3b04 Move (dH dV) void)
(def-toolbox 0x2204 MovePortTo (h v) void)
(def-toolbox 0x3a04 MoveTo (h v) void)
(def-toolbox 0x6704 NewRgn () long)
(def-toolbox 0x5204 NotEmptyRect ((long rectPtr)) word)
(def-toolbox 0x9204 ObscureCursor () void)
(def-toolbox 0xc404 OffsetPoly ((long polyHandle) dH dV) void)
(def-toolbox 0x4b04 OffsetRect ((long rectPtr) dH dV) void)
(def-toolbox 0x6f04 OffsetRgn ((long rgnHandle) dH dV) void)
(def-toolbox 0xc104 OpenPoly () long)
(def-toolbox 0x1804 OpenPort ((long portPtr)) void)
(def-toolbox 0x6d04 OpenRgn () void)
(def-toolbox 0x6304 PaintArc ((long rectPtr) startAngle arcAngle) void)
(def-toolbox 0x5904 PaintOval ((long rectPtr)) void)
(def-toolbox 0x7f04 PaintPixels ((long paintParamPtr)) void)
(def-toolbox 0xbd04 PaintPoly ((long polyHandle)) void)
(def-toolbox 0x5404 PaintRect ((long rectPtr)) void)
(def-toolbox 0x7a04 PaintRgn ((long rgnHandle)) void)
(def-toolbox 0x5e04 PaintRRect ((long rectPtr) ovalWidth ovalHeight) void)
(def-toolbox 0x3604 PenNormal () void)
(def-toolbox 0xd604 PPToPort ((long srcLocPtr) (long srcRectPtr) destX destY transferMode) void)
(def-toolbox 0x5004 Pt2Rect ((long point1Ptr) (long point2Ptr) (long rectPtr)) void)
(def-toolbox 0x4f04 PtInRect ((long pointPtr) (long rectPtr)) word)
(def-toolbox 0x7504 PtInRgn ((long pointPtr) (long rgnHandle)) word)
(def-toolbox 0x8604 Random () word)
(def-toolbox 0x7604 RectInRgn ((long rectPtr) (long rgnHandle)) word)
(def-toolbox 0x6c04 RectRgn ((long rgnHandle) (long rectPtr)) void)
(def-toolbox 0xce04 RestoreBufDims ((long sizeInfoPtr)) void)
(def-toolbox 0xcd04 SaveBufDims ((long sizeInfoPtr)) void)
(def-toolbox 0x8904 ScalePt ((long pointPtr) (long srcRectPtr) (long destRectPtr)) void)
(def-toolbox 0x7e04 ScrollRect ((long rectPtr) dH dV (long updateRgnHandle)) void)
(def-toolbox 0x4d04 SectRect ((long rect1Ptr) (long rect2Ptr) (long intersectRectPtr)) word)
(def-toolbox 0x7104 SectRgn ((long rgn1Handle) (long rgn2Handle) (long destRgnHandle)) void)
(def-toolbox 0x1404 SetAllSCBs (newSCB) void)
(def-toolbox 0xb004 SetArcRot (arcRotValue) void)
(def-toolbox 0xa204 SetBackColor (backColor) void)
(def-toolbox 0x3404 SetBackPat ((long patternPtr)) void)
(def-toolbox 0xcb04 SetBufDims (maxWidth maxFontHeight maxFBRExtent) void)
(def-toolbox 0xd404 SetCharExtra ((long charExtra)) void)
(def-toolbox 0x2404 SetClip ((long rgnHandle)) void)
(def-toolbox 0xc604 SetClipHandle ((long rgnHandle)) void)
(def-toolbox 0x1004 SetColorEntry (tableNumber entryNUmber newColor) void)
(def-toolbox 0x0e04 SetColorTable (tableNumber (long srcTablePtr)) void)
(def-toolbox 0x8e04 SetCursor ((long cursorPtr)) void)
(def-toolbox 0x6a04 SetEmptyRgn ((long rgnHandle)) void)
(def-toolbox 0x9404 SetFont ((long newFontHandle)) void)
(def-toolbox 0x9804 SetFontFlags (fontFlags) void)
(def-toolbox 0xd004 SetFontID ((long fontID)) void)
(def-toolbox 0xa004 SetForeColor (foreColor) void)
(def-toolbox 0x4404 SetGrafProcs ((long grafProcsPtr)) void)
(def-toolbox 0xb604 SetIntUse (useInt) void)
(def-toolbox 0x1604 SetMasterSCB (masterSCB) void)
(def-toolbox 0x2304 SetOrigin (h v) void)
(def-toolbox 0x3204 SetPenMask ((long maskPtr)) void)
(def-toolbox 0x2e04 SetPenMode (penMode) void)
(def-toolbox 0x3004 SetPenPat ((long patternPtr)) void)
(def-toolbox 0x2c04 SetPenSize (penWidth penHeight) void)
(def-toolbox 0x2a04 SetPenState ((long penStatePtr)) void)
(def-toolbox 0x3e04 SetPicSave ((long picSaveValue)) void)
(def-toolbox 0x1b04 SetPort ((long portPtr)) void)
(def-toolbox 0x1d04 SetPortLoc ((long locInfoPtr)) void)
(def-toolbox 0x1f04 SetPortRect ((long rectPtr)) void)
(def-toolbox 0x2104 SetPortSize (portWidth portHeight) void)
(def-toolbox 0x8204 SetPt ((long srcPtPtr) h v) void)
(def-toolbox 0x8704 SetRandSeed ((long randomSeed)) void)
(def-toolbox 0x4a04 SetRect ((long rectPtr) left top right bottom) void)
(def-toolbox 0x6b04 SetRectRgn ((long rgnHandle) left top right bottom) void)
(def-toolbox 0x1204 SetSCB (scanLine newSCB) void)
(def-toolbox 0x3804 SetSolidBackPat (colorNum) void)
(def-toolbox 0x3704 SetSolidPenPat (colorNum) void)
(def-toolbox 0x9e04 SetSpaceExtra ((long spaceExtra)) void)
(def-toolbox 0x8d04 SetStdProcs ((long stdProcRecPtr)) void)
(def-toolbox 0xb204 SetSysFont ((long fontHandle)) void)
(def-toolbox 0x9a04 SetTextFace (textFace) void)
(def-toolbox 0x9c04 SetTextMode (textMode) void)
(def-toolbox 0xd204 SetTextSize (textSize) void)
(def-toolbox 0x4604 SetUserField ((long userFieldValue)) void)
(def-toolbox 0xc804 SetVisHandle ((long rgnHandle)) void)
(def-toolbox 0xb404 SetVisRgn ((long rgnHandle)) void)
(def-toolbox 0x9104 ShowCursor () void)
(def-toolbox 0x2804 ShowPen () void)
(def-toolbox 0x3904 SolidPattern (colorNum (long patternPtr)) void)
(def-toolbox 0xad04 StringBounds ((long stringPtr) (long resultPtr)) void)
(def-toolbox 0xa904 StringWidth ((long stringPtr)) word)
(def-toolbox 0x8104 SubPt ((long srcPtPtr) (long destPtPtr)) void)
(def-toolbox 0xaf04 TextBounds ((long textPtr) textLength (long resultPtr)) void)
(def-toolbox 0xab04 TextWidth ((long textPtr) textLength) word)
(def-toolbox 0x4e04 UnionRect ((long rect1Ptr) (long rect2Ptr) (long unionRectPtr)) void)
(def-toolbox 0x7204 UnionRgn ((long rgn1Handle) (long rgn2Handle) (long unionRgnHandle)) void)
(def-toolbox 0x7404 XorRgn ((long rgn1Handle) (long rgn2Handle) (long xorRgnHandle)) void)
))

142
ssc/iigs/u2-debug.fnl Normal file
View file

@ -0,0 +1,142 @@
(import-macros {:sss ! : compile} :ssc.macros)
(local {: cmd : response} (require :link.udpdebug))
; sudo route add -net 172.24.1.0/24 gw 192.168.2.25
; -VEDRIVE
; CAT,S1
; BLOAD UDPDEBUG.SYSTEM, TSYS, A$2000
; CALL-151
; 2000S
(local Ssc (require :ssc))
(local ssc (Ssc))
(compile ssc
(start-symbol boot-8)
(org 0x2000)
(fn boot-8 ()
(asm (clc) (xce) (rep 0x30) ; disable emulation mode, 16-bit index registers
(jsr debug-server-loop)
(sec) (xce))) ; re-enter emulation mode
(require ssc.stdlib)
(require ssc.iigs.toolbox)
(macro out [#(! (WriteLine (far-ref (pstr [$2]))))])
(buffer hexbuf (cstr " "))
(fn printnum (num)
(long! (ref hexbuf) (HexIt num))
(WriteCString (far-ref hexbuf)))
(require ssc.iigs.uthernet2)
(fn u2-init-debug-server ()
(out "Starting server")
(u2-reset)
(u2-udp-server-start 6502))
(buffer u2-debug-buffer 1500)
(predef-fn u2-debug-server-poll () void far)
(global word u2-debug-server-paused false)
(fn u2-debug-server-cmd-write (msgid)
(set! u2-debug-server-paused true)
(let (count (word-at (ref u2-debug-buffer)) index 2)
(printnum count) (out ": # of blocks to write")
(while (> count 0)
(let (addr (long-at (+ (ref u2-debug-buffer) index))
size (word-at (+ (ref u2-debug-buffer) index 4)))
(printnum (hiword addr)) (printnum (loword addr)) (printnum size) (out ": writing")
(memcpy (+ (far-ref u2-debug-buffer) index 6) addr size)
(set! index (+ index size 6))
(set! count (- count 1))))
(u2-tx-begin 2)
(u2-write msgid)
(u2-write [response.ack])
(u2-tx-complete)))
(fn u2-debug-server-cmd-read (msgid)
(let (index 6 totalsize 0 count (word-at (ref u2-debug-buffer)))
(printnum count) (out ": # of blocks to read")
(while (> count 0)
(let (size (word-at (+ (ref u2-debug-buffer) index)))
(set! totalsize (+ totalsize size))
(set! index (+ index 6))
(set! count (- count 1))))
(u2-tx-begin (+ totalsize 2))
(u2-write msgid)
(u2-write [response.data])
(set! count (word-at (ref u2-debug-buffer)))
(set! index 2)
(while (> count 0)
(let (addr (long-at (+ (ref u2-debug-buffer) index))
size (word-at (+ (ref u2-debug-buffer) index 4)))
(u2-write-farbuf addr size)
(set! index (+ index 6))
(set! count (- count 1))))
(u2-tx-complete)))
(fn u2-debug-server-cmd-exec (msgid)
(let (val (asm (jsr u2-debug-buffer))
longval (asm-long))
(u2-tx-begin 8)
(u2-write msgid)
(u2-write [response.data])
(u2-write-word val)
(u2-write-word (loword longval))
(u2-write-word (hiword longval))
(u2-tx-complete)))
(fn u2-debug-server-cmd-pause (msgid)
(set! u2-debug-server-paused (word-at (ref u2-debug-buffer)))
(u2-tx-begin 3)
(u2-write msgid)
(u2-write [response.ack])
(u2-write u2-debug-server-paused)
(u2-tx-complete)
(while u2-debug-server-paused
(u2-debug-server-poll)))
(fn u2-debug-server-cmd-ping (msgid)
(u2-tx-begin 2)
(u2-write msgid)
(u2-write [response.ack])
(u2-tx-complete))
(fn u2-debug-server-cmd (msgid cmd)
(if (= cmd [cmd.write]) (u2-debug-server-cmd-write msgid)
(= cmd [cmd.read]) (u2-debug-server-cmd-read msgid)
(= cmd [cmd.eval]) (u2-debug-server-cmd-exec msgid)
(= cmd [cmd.pause]) (u2-debug-server-cmd-pause msgid)
(= cmd [cmd.ping]) (u2-debug-server-cmd-ping msgid)))
(far-fn u2-debug-server-poll ()
(let (size (u2-rx-begin))
(when size
(let (msgid (u2-read)
cmd (u2-read))
(printnum msgid) (printnum cmd) (out ": Got message!")
(u2-read-buf (ref u2-debug-buffer) (- size 2))
(u2-rx-complete)
(u2-set-tx-dest u2-udp-recv-ip u2-udp-recv-port)
(u2-debug-server-cmd msgid cmd)))))
(fn debug-server-loop ()
(TextStartUp)
(IMStartUp)
(u2-init-debug-server)
(forever (u2-debug-server-poll)))
)
(let [Prodos (require :asm.prodos)
prg (ssc:assemble)
disk (Prodos "ProDOS_Blank.dsk")]
(disk:update-volume-header {:name "UDP.DEBUG"})
(disk:add-file "UDPDEBUG.SYSTEM" Prodos.file-type.SYS 0x2000 (. (prg:org 0x2000) :block :bytes))
(disk:write "UdpDebug.dsk"))
ssc

149
ssc/iigs/uthernet2.fnl Normal file
View file

@ -0,0 +1,149 @@
; uthernet ii driver
(local config {
:gateway [172 24 1 1]
:netmask [255 255 255 0]
:ip [172 24 1 6]
:slot 3
:mac [0xAD 0xE9 0xA5 0x4A 0x6D 0x66]
})
(import-macros {:sss ! : compile} :ssc.macros)
(fn reg [base] (tostring (+ base (* config.slot 16))))
(let [U2-MODE (reg 0xc084)
U2-ADDR-HI (reg 0xc085)
U2-ADDR-LO (reg 0xc086)
U2-DATA (reg 0xc087)]
#(compile $1
(macro u2-addr! [#[:word! [:ref U2-ADDR-HI] [:byteswap $2]]])
(macro u2-read [#[:byte-at [:ref U2-DATA]]])
(macro u2-write [#[:byte! [:ref U2-DATA] $2]])
(fn u2-read-word ()
(let (hi (u2-read)
lo (u2-read))
(| (byteswap hi) lo)))
(fn u2-write-word (w)
(let (hi (& (byteswap w) 0xff)
lo (& w 0xff))
(u2-write hi)
(u2-write lo)))
(fn u2-read-buf (addr count)
(asm (lda count) (tax)
(ldy 0)
(sep 0x20)
loop
(lda [U2-DATA])
(sta (addr) y)
(iny)
(dex)
(bne loop)
(rep 0x20)))
(fn u2-write-buf (addr count)
(asm (lda count) (tax)
(ldy 0)
(sep 0x20)
loop
(lda (addr) y)
(sta [U2-DATA])
(iny)
(dex)
(bne loop)
(rep 0x20)))
(fn u2-write-farbuf ((long addr) count)
(asm (lda addr) (sta [$1.ADDR_LO])
(lda addr 2) (sta [$1.ADDR_HI])
(lda count) (tax)
(ldy 0)
(sep 0x20)
loop
(lda (([$1.ADDR_LO])) y)
(sta [U2-DATA])
(iny)
(dex)
(bne loop)
(rep 0x20)))
(asm u2-ipconfig
(bytes [config.gateway])
(bytes [config.netmask])
(bytes [config.mac])
(bytes [config.ip]))
(fn u2-reset ()
(byte! (ref [U2-MODE]) 0x80)
(byte! (ref [U2-MODE]) 0x03)
(u2-addr! 0x0001)
(u2-write-buf (ref u2-ipconfig) 18)
(u2-addr! 0x0016) (u2-write 0)) ; disable interrupts
(fn u2-udp-server-start (port)
(u2-addr! 0x001a)
(u2-write 0x03) ; allocate all 8kb rx buffer to socket 0
(u2-write 0x03) ; same, but tx
(u2-addr! 0x0400)
(u2-write 0x42) ; UDP, filter by MAC
(u2-addr! 0x0404) ; set port
(u2-write-word port)
(u2-addr! 0x0401)
(u2-write 0x01) ; open socket
(u2-addr! 0x0403)
(printnum (u2-read)) (out ": Opened socket"))
(fn u2-data-ready ()
(u2-addr! 0x0426)
(u2-read-word))
(define u2-buf-mask 0x1fff)
(global long u2-udp-recv-ip 0)
(global word u2-udp-recv-port 0)
(global word u2-udp-recv-size 0)
(global word u2-udp-recv-rxrd 0)
(fn u2-rx-complete ()
(u2-addr! 0x0428)
(u2-write-word (+ u2-udp-recv-rxrd 8 u2-udp-recv-size))
(u2-addr! 0x0401)
(u2-write 0x40)) ; RECV command
(fn u2-rxtx-ptr (rd base) (+ (& rd u2-buf-mask) base))
(fn u2-rx-begin ()
(if (u2-data-ready)
(do (u2-addr! 0x0428)
(set! u2-udp-recv-rxrd (u2-read-word))
(let (rxrd (u2-rxtx-ptr u2-udp-recv-rxrd 0x6000))
(u2-addr! rxrd)
(u2-read-buf (ref u2-udp-recv-ip) 8)
; convert from network order
(set! u2-udp-recv-port (byteswap u2-udp-recv-port))
(set! u2-udp-recv-size (byteswap u2-udp-recv-size))
u2-udp-recv-size))
0))
(fn u2-set-tx-dest ((long ip) port)
(u2-addr! 0x040c)
(u2-write-word (byteswap (loword ip))) ; ip is always network order
(u2-write-word (byteswap (hiword ip)))
(u2-write-word port))
(global word u2-udp-send-size 0)
(fn u2-tx-begin (size)
(set! u2-udp-send-size size)
(let (freesize 0) (while (< freesize size)
(u2-addr! 0x0420) (set! freesize (u2-read-word))))
(u2-addr! 0x0424)
(let (txwr (u2-rxtx-ptr (u2-read-word) 0x4000))
(u2-addr! txwr)))
(fn u2-tx-complete ()
(u2-addr! 0x0424)
(let (txwr (u2-read-word))
(u2-addr! 0x0424)
(u2-write-word (+ txwr u2-udp-send-size))
(u2-addr! 0x0401)
(u2-write 0x20))) ; SEND command
))

552
ssc/init.fnl Normal file
View file

@ -0,0 +1,552 @@
; ssc: the sufficiently simple compiler
; The goal of ssc is to allow simple prefix expressions to be compiled into 65816 code that
; would run at least as fast or faster than the equivalent threaded Forth code. Complex
; optimizations are a non-goal; if you want to tune the generated code, go ahead and write
; the assembly directly.
; * Expressions have 3 data types: word (2 bytes), long (4 bytes), void (0 bytes).
; * Expressions return their results in different places depending on type - word values are stored in the A register,
; long values are stored in the direct page at LONG_LO / LONG_HI.
; * Data and return addresses are mixed on one stack, unlike Forth.
; * Function calls take a fixed number of arguments, and return 0 or 1 results. The compiler enforces arity checking.
; * To call a function taking arguments [arg1 arg2 arg3], all 3 arguments should be pushed to the stack before calling.
; When the function takes control, the stack should look like this:
; arg1 arg2 arg3 return-address
; * The caller is responsible for removing all arguments from the stack once the function returns.
; * The caller is responsible for preserving the A, X and Y registers, if this is desirable.
; * If the function returns a value, it is stored in the A/LONG register, like any expression.
; * If a function returns no result, it is not obliged to preserve the A/LONG register.
; * Multitasking is achieved by overlapping the D and S registers on the same 256-byte page of memory.
; Yielding to a new task involves saving the S register, setting the D register to the new task's page,
; then setting the S register to the saved value in the old task.
; * Useful task-local "registers" are kept at the beginning of the page, and the stack grows down from the end of the page.
; * DP register list:
; * LONG (32-bit "register")
; * Last suspended value of S
; * Mailbox
; * Pointer to next task
; Compiler notes:
; Expressions are of the form [:function arg1 arg2 arg3]
; args are either strings (symbols) or numbers
(local Object (require :core.object))
(local lume (require :lib.lume))
(local Ssc (Object:extend))
(local Prg (require :asm.asm))
(local util (require :lib.util))
(local {: loword : hiword : pairoff : countiter : condlist : prototype} util)
(fn Ssc.new [self ?opts]
(local opts (or ?opts {}))
(set self.prg (Prg.new (or opts.prg (?. opts.parent :prg)) :65816))
(set self.forms (prototype (or opts.forms (?. opts.parent :forms) self.__index.forms)))
(set self.functions (prototype (or (?. opts.parent :functions) {})))
(set self.locals [])
(set self.addr-to-callsite {})
(set self.modules (prototype (or (?. opts.parent :modules) {})))
(set self.globals (prototype (or (?. opts.parent :globals) {})))
(set self.constants (prototype (or (?. opts.parent :constants) {:true 0xffff true 0xffff :false 0 false 0})))
(set self.macros (prototype (or opts.macros (?. opts.parent :macros) self.__index.macros)))
(set self.macrobarriers (prototype (or (?. opts.parent :macrobarriers) {:fn true :far-fn true :do true})))
(set self.setters (prototype (or (?. opts.parent :setters) {})))
(set self.dp-vars (or (?. opts.parent :dp-vars) 0))
(set self.gensym-count (or (?. opts.parent :gensym-count) 0))
(set self.LONG_LO (or (?. opts.parent :LONG_LO) (self:alloc-dp-var)))
(set self.LONG_HI (or (?. opts.parent :LONG_HI) (self:alloc-dp-var)))
(set self.ADDR_LO (or (?. opts.parent :ADDR_LO) (self:alloc-dp-var)))
(set self.ADDR_HI (or (?. opts.parent :ADDR_HI) (self:alloc-dp-var))))
(fn Ssc.alloc-dp-var [self]
(let [addr (.. :d self.dp-vars)]
(set self.dp-vars (+ self.dp-vars 2))
addr))
(fn Ssc.gensym [self ?prefix]
(let [sym (.. "<gensym " self.gensym-count (if ?prefix (.. " " ?prefix ">") ">"))]
(set self.gensym-count (+ self.gensym-count 1))
sym))
(fn Ssc.push [self name expr ?etype]
(let [opgen (if (= ?etype :register) {:lo #[:flatten]}
(self:expr-opgen expr ?etype))
etype (if (= ?etype :register) :word
?etype ?etype
opgen.hi :long
:word)
c-setup (when opgen.setup (opgen.setup))
c-hi (when opgen.hi [(opgen.hi :lda) [:pha]])
loc {: name :type (if c-hi :word :placeholder)}
_ (table.insert self.locals loc) ; if we push a high word onto the stack it shifts stack offsets
c-lo [(opgen.lo :lda) [:pha]]]
(set loc.type etype)
(lume.concat [:block c-setup] c-hi c-lo)))
(fn Ssc.remove-local [self ?name]
(let [loc (. self.locals (length self.locals))]
(when (not= loc.name ?name) (error (.. "Internal stack error: expected " (or ?name "temporary") ", got " (or loc.name "temporary"))))
(tset self.locals (length self.locals) nil)
loc))
(fn Ssc.drop [self ?name]
(match (. (self:remove-local ?name) :type)
:word [:ply]
:long [:block [:ply] [:ply]]))
(fn Ssc.pop [self ?name]
(let [{:type etype} (self:remove-local ?name)]
(values (match etype
:word [:pla]
:long [:block [:pla] [:sta self.LONG_LO] [:pla] [:sta self.LONG_HI]])
etype)))
(fn Ssc.was-dropped [self localcount]
(set self.locals (lume.slice self.locals 1 (- (length self.locals) localcount))))
(fn Ssc.define-fn [self name locals f]
(assert (not (self:defining?)) "Can't nest function definitions")
(set self.defining-fn name)
(set self.locals (when locals (lume.clone locals)))
(set self.callsites {})
(let [result (f)]
(set self.defining-fn nil)
(set self.callsites {})
(assert (or (and (= locals nil) (= self.locals nil))
(= (length self.locals) (length locals)))
(.. "Left locals on stack?? Expected " (fv locals) " got " (fv self.locals)))
(set self.locals [])
result))
(fn Ssc.defining? [self] (not= self.defining-fn nil))
; operations that work on the accumulator, like adc or sbc
; optimization strategy: keep the current result in the accumulator, work from the stack or immediate values
; 1. take "right" arguments and push them (unless already on stack, immediate, or absolute)
; 2. load left into accumulator
; 3. apply until done
(fn Ssc.accumulation-op [self op first ...]
(var etype (self:type-expr first))
(for [i 1 (select :# ...)] (when (= (self:type-expr (select i ...)) :long) (set etype :long)))
(let [args (icollect [_ val (ipairs [...])] (self:push-opgen val))
setup (icollect [_ {: setup} (ipairs args)] (when setup (setup)))
acc (: self (.. :expr- etype) first)
operations (icollect [i addr (ipairs args)] (op etype addr i))
cleanup (icollect [_ {: cleanup} (ipairs args)] (when cleanup (cleanup)))]
(values (lume.concat [:block] setup [acc] operations cleanup) etype)))
(fn Ssc.simple-accumulator [self op etype {: lo : hi} ?defaulthi]
(match etype
:word (lo op)
:long [:block [:lda self.LONG_LO] (lo op) [:sta self.LONG_LO]
[:lda self.LONG_HI] (if hi (hi op) [op (or ?defaulthi 0)]) [:sta self.LONG_HI]]))
; comparisons assume left-hand side was in accumulator and cmp (right-hand side) was just executed.
; For lobranch, the branch should execute if the comparison is FALSE; the label passed is for the false branch.
; For hibranch, the branch should not execute if the low word still needs to be compared; otherwise, $1 is the true branch,
; and $2 is the false branch.
(set Ssc.comparisons
{:< {:hibranch #[:block [:bcc $1] [:bne $2]] :lobranch #[:bcs $1] :opposite :>=}
:> {:swap :< :opposite :<=}
:>= {:hibranch #[:block [:bcc $2] [:bne $1]] :lobranch #[:bcc $1] :opposite :<}
:<= {:swap :>= :opposite :>}
:= {:hibranch #[:bne $2] :lobranch #[:bne $1] :opposite :not=}
:not= {:hibranch #[:bne $1] :lobranch #[:beq $1] :opposite :=}
})
(fn Ssc.rewrite-condition [self cond] ; rewrite comparisons down to primitives - <, >=, =, not=, or, and. "or" and "and" can nest.
(match cond
(where [op] (?. self.comparisons op :hibranch)) ; already a primitive op
cond
(where [op lhs rhs] (?. self.comparisons op :swap))
[(. self.comparisons op :swap) rhs lhs]
[:not [:not expr]]
(self:rewrite-condition expr)
(where [:not [op lhs rhs]] (?. self.comparisons op :opposite))
(self:rewrite-condition [(. self.comparisons op :opposite) lhs rhs])
(where [:not [op & tests]] (or (= op :or) (= op :and))) ; !(x||y) => (!x)&&(!y)
(lume.concat [(if (= op :or) :and :or)] (icollect [_ test (ipairs tests)] (self:rewrite-condition [:not test])))
[:not expr]
(self:rewrite-condition [:not (self:rewrite-condition expr)])
(where [op & tests] (or (= op :or) (= op :and)))
(lume.concat [op] (icollect [_ test (ipairs tests)] (self:rewrite-condition test)))
_ [:not= cond 0]))
(fn Ssc.gen-condition [self cond truelabel falselabel ?depth ?branch-when-true]
(let [depth (or ?depth 0)
cond (self:rewrite-condition cond)
[op & args] cond
cmp (. self.comparisons op)]
(if cmp
(let [[lhs rhs] args
ropgen (self:push-opgen rhs)
pre (when ropgen.setup (ropgen.setup))
lopgen (self:expr-opgen lhs)
left (when lopgen.setup (lopgen.setup))
truebranch (.. :-if-true-cleanup- depth)
falsebranch (.. :-if-false-cleanup- depth)
hibranch (when lopgen.hi
[(lopgen.hi :lda) (ropgen.hi :cmp) (cmp.hibranch truebranch falsebranch)])
lobranch [(lopgen.lo :lda) (ropgen.lo :cmp) (cmp.lobranch falsebranch)]
cleanup (if ropgen.cleanup (ropgen.cleanup) [:flatten])
post (if cleanup [truebranch cleanup [:brl truelabel] falsebranch cleanup [:brl falselabel]]
?branch-when-true [[:bra truelabel]])]
(lume.concat [:block] [pre] [left] hibranch lobranch post))
(or (= op :or) (= op :and))
(lume.concat [:block]
(icollect [itest test (ipairs args)]
(let [lastclause (= itest (length args))
nextlabel (.. :-next- op :-clause- itest :- depth)
whentrue (if (= op :or) truelabel (if lastclause truelabel nextlabel))
whenfalse (if (= op :or) (if lastclause falselabel nextlabel) falselabel)]
[:block (self:gen-condition test whentrue whenfalse (+ depth 1) (and (= op :or) (not lastclause))) nextlabel])))
(error (.. "Internal error: can't handle conditional " op)))))
(fn Ssc.cmp-to-bool [self op ...] (self:expr-poly [:if [op ...] true false]))
(fn Ssc.compile-function-generic [self name args body post-body returnaddr-type call-instruction]
(let [arglocals (self:parse-parameters args)]
(self:define-fn name (lume.concat arglocals [{:type returnaddr-type :returnaddr true}])
#(let [(c-function etype) (self:expr-poly body)]
(self.org:append name c-function (table.unpack post-body))
{:arity (length args) :args arglocals :org self.org :type etype : name : call-instruction}))))
(fn Ssc.compile-function [self name args ...] (self:compile-function-generic name args [:do ...] [[:rts]] :word :jsr))
(fn Ssc.compile-far-function [self name args ...] (self:compile-function-generic name args [:do [:asm [:phb] [:phk] [:plb]] ...] [[:plb] [:rtl]] :long :jsl))
(fn Ssc.asm-localify [self block]
(icollect [_ inst (ipairs block)]
(match inst
[op [:ref sym] & rest] [op sym (table.unpack rest)]
(where [op loc ?off] (and (= (type loc) :string) (self:local-offset loc)))
[op (+ (self:local-offset loc) (or ?off 0)) :s]
(where [op [loc ?off] :y] (and (= (type loc) :string) (self:local-offset loc)))
[op [(+ (self:local-offset loc) (or ?off 0)) :s] :y]
[:block] (self:asm-localify inst)
_ inst)))
(fn string? [v] (= (type v) :string))
(fn xxxx-at [v] ; matches byte-at, word-at, long-at
(when (string? v)
(let [(i-at i-done) (v:find :-at)]
(when (and i-at (= i-done (length v))) (v:sub 1 (- i-at 1))))))
(fn Ssc.compile-read-at [self ref etype] ; opgen catches the trivial cases; we have to compile ref to get a pointer
(let [opgen (self:expr-opgen ref)
pre (when opgen.setup (opgen.setup))
load (if opgen.hi [:lda [[self.ADDR_LO]] :y] [:lda [self.ADDR_LO] :y])
load (if (= etype :byte) [:block [:rep 0x30] load [:sep 0x30] [:and 0xff]] load)]
(values (condlist :block pre (opgen.lo :lda) [:sta self.ADDR_LO]
(when opgen.hi [:block (opgen.hi :lda) [:sta self.ADDR_HI]])
[:ldy 0] load
(when (= etype :long) [:block [:sta self.LONG_LO] [:ldy 2] load [:sta self.LONG_HI]]))
(if (= etype :byte) :word etype))))
(set Ssc.forms
{:asm (fn [self ...] (if (self:defining?) (self:asm-localify [:block ...]) (self.org:append (table.unpack (self:asm-localify [...])))))
:asm-long (fn [self ...] (values (self:asm-localify [:block ...]) :long))
:org (lambda [self org] (set self.org (self.prg:org org)))
:start-symbol (lambda [self symbol] (set self.prg.start-symbol symbol))
:form (lambda [self name func] (tset self.forms name func))
:define (lambda [self name val] (tset self.constants name val))
:macro (lambda [self name func] (tset self.macros name func))
:macrobarrier (lambda [self formname] (tset self.macrobarriers formname true))
:setter (lambda [self name arg ...]
(assert (= (length arg) 1))
(tset self.setters name (self:compile-function (.. :-set- name) arg ...)))
:require (lambda [self name ...]
(when (= (. self.modules name) nil)
(let [mod (util.reload name)
func (if (= (type mod) :function) mod mod.module)]
(tset self.modules name mod)
(func self ...))))
:global (lambda [self etype name ?const]
(tset self.globals name {:type etype : name})
(self.org:append [:hot-preserve name
(match etype
:word [:dw ?const]
:long [:dl ?const]
_ (error (.. "Unrecognized type " (fv etype))))]))
:buffer (lambda [self name bytes-or-size]
(self.org:append [:hot-preserve name [:bytes (match (type bytes-or-size)
:string bytes-or-size
:number (string.rep "\x00" bytes-or-size))]]))
:do (fn [self ...]
(var etype-body :void)
(local c-body (lume.concat [:block] (icollect [i (countiter (select :# ...))]
(let [(expr etype) (self:expr-poly (select i ...))]
(set etype-body etype)
expr))))
(values c-body etype-body))
:let (fn [self bindings ...]
(let [compiled-bindings (icollect [_ symbol expr (pairoff bindings)] (self:push symbol expr))
(compiled-body etype) (self:expr-poly [:do ...])
compiled-cleanup (icollect [i-half (countiter (/ (length bindings) 2))]
(self:drop (. bindings (- (length bindings) (* i-half 2) -1))))]
(values (lume.concat [:block] compiled-bindings [compiled-body] compiled-cleanup) etype)))
:fn (lambda [self name args ...] (tset self.functions name (self:compile-function name args ...)))
:far-fn (lambda [self name args ...] (tset self.functions name (self:compile-far-function name args ...)))
:predef-fn (lambda [self name args etype ?far]
(tset self.functions name {:arity (length args) :args (self:parse-parameters args) :org self.org :type etype : name :call-instruction (if (= ?far :far) :jsl :jsr)}))
:if (lambda [self test iftrue ?else ...]
(let [(c-true truetype) (self:expr-poly iftrue)
iffalse (if (> (select :# ...) 0) [:if ?else ...] ?else)
(c-false falsetype) (when (not= iffalse nil) (self:expr-poly iffalse))
etype (if (not= truetype falsetype) :void truetype)
block [:block (self:gen-condition test :-if-true- :-if-false-) :-if-true- c-true]
cl-false (if (not= iffalse nil) [[:bra :-if-done-] :-if-false- c-false :-if-done-]
[:-if-false-])]
(values (lume.concat block cl-false) etype)))
:while (lambda [self test ...]
(let [block [:block :-loop-top- (self:gen-condition test :-enter-loop- :-exit-loop-) :-enter-loop-]
c-body (self:expr-poly [:do ...])]
(values (lume.concat block [c-body [:brl :-loop-top-] :-exit-loop-]) :void)))
:forever (lambda [self ...] [:block :-loop-top- (self:expr-poly [:do ...]) [:brl :-loop-top-]])
:+ (lambda [self first ...]
(self:accumulation-op
(fn [etype opgen]
(if (and (= etype :word) opgen.const (>= opgen.const -2) (<= opgen.const 2))
(match opgen.const 1 [:inc] 2 [:block [:inc] [:inc]]
-1 [:dec] -2 [:block [:dec] [:dec]])
[:block [:clc] (self:simple-accumulator :adc etype opgen)]))
first ...))
:- (lambda [self first ...]
(if (= (select :# ...) 0)
(match (self:type-expr first) :word [:block (self:expr-word first) [:eor 0xffff] [:inc]] ; negate with two's complement
:long (self:expr-poly [:- 0 first])) ; just subtract from 0
(self:accumulation-op
(fn [etype opgen]
(if (and (= etype :word) (>= opgen.const -2) (<= opgen.const 2))
(match opgen.const -1 [:inc] -2 [:block [:inc] [:inc]]
1 [:dec] 2 [:block [:dec] [:dec]])
[:block [:sec] (self:simple-accumulator :sbc etype opgen)]))
first ...)))
:| (lambda [self first ...] (self:accumulation-op #(self:simple-accumulator :ora $...) first ...))
:& (lambda [self first ...] (self:accumulation-op #(self:simple-accumulator :and $...) first ...))
:^ (lambda [self first ...] (self:accumulation-op #(self:simple-accumulator :eor $...) first ...))
:= (lambda [self lhs rhs] (self:cmp-to-bool := lhs rhs))
:not= (lambda [self lhs rhs] (self:cmp-to-bool :not= lhs rhs))
:< (lambda [self lhs rhs] (self:cmp-to-bool :< lhs rhs))
:> (lambda [self lhs rhs] (self:cmp-to-bool :> lhs rhs))
:>= (lambda [self lhs rhs] (self:cmp-to-bool :>= lhs rhs))
:<= (lambda [self lhs rhs] (self:cmp-to-bool :<= lhs rhs))
:not (lambda [self bool] (self:cmp-to-bool :not bool))
:or (lambda [self ...] (self:cmp-to-bool :or ...))
:and (lambda [self ...] (self:cmp-to-bool :and ...))
:loword (lambda [self long]
(let [{: lo : setup} (self:expr-opgen long :long)]
(lume.concat [:block] [(when setup (setup))] [(lo :lda)])))
:hiword (lambda [self long]
(let [{: hi : setup} (self:expr-opgen long :long)]
(lume.concat [:block] [(when setup (setup))] [(hi :lda)])))
:ref (lambda [self label] [:lda #(loword ($1:lookup-addr label))])
:far-ref (lambda [self label] (values [:block [:lda #(loword ($1:lookup-addr label))] [:sta self.LONG_LO]
[:lda #(hiword ($1:lookup-addr label))] [:sta self.LONG_HI]] :long))
:byteswap (lambda [self word] [:block (self:expr-word word) [:xba]])
:long (lambda [self value] (values [:block (self:expr-word value) [:sta self.LONG_LO] [:lda 0] [:sta self.LONG_HI]] :long))
:byte-at (lambda [self ref] (self:compile-read-at ref :byte))
:word-at (lambda [self ref] (self:compile-read-at ref :word))
:long-at (lambda [self ref] (self:compile-read-at ref :long))
:set! (lambda [self lhs value]
(if (and (= (type lhs) :string) (. self.setters lhs))
(self:compile-function-call (. self.setters lhs) [value])
(self:opgen-lhs lhs)
(let [{:lo val-lo :hi val-hi : setup} (assert (self:expr-opgen value) (.. (fv value) " did not produce a value"))
c-setup (when setup (setup))
{: lo : hi} (self:opgen-lhs lhs)
c-lo [:flatten (val-lo :lda) (lo :sta)]
c-hi (when hi [:flatten (if val-hi (val-hi :lda) [:lda 0]) (hi :sta)])
block [:block]]
(lume.push block c-setup c-lo c-hi)
(values block :void))
(and (= (type lhs) :table) (xxxx-at (. lhs 1)))
(let [ropgen (self:push-opgen value)
pre1 (when ropgen.setup (ropgen.setup))
lopgen (self:expr-opgen (. lhs 2))
pre2 (when lopgen.setup (lopgen.setup))
etype (xxxx-at (. lhs 1))
store (if lopgen.hi [:sta [[self.ADDR_LO]] :y] [:sta [self.ADDR_LO] :y])
store (if (= etype :byte) [:block [:rep 0x30] store [:sep 0x30]] store)]
(values (condlist :block pre1 pre2 (lopgen.lo :lda) [:sta self.ADDR_LO]
(when lopgen.hi [:block (lopgen.hi :lda) [:sta self.ADDR_HI]])
(ropgen.lo :lda) [:ldy 0] store
(when (= etype :long) [:block (if ropgen.hi (ropgen.hi :lda) [:lda 0]) [:ldy 2] store])
(when ropgen.cleanup (ropgen.cleanup)))
:void))
(error (.. (fv lhs) " not valid as a target of set!"))))
})
(set Ssc.macros
{:getter (lambda [self name ...] (let [getter-name (.. "<get " name ">")]
[:do [:fn getter-name [] ...]
[:define name [getter-name]]]))
:when (lambda [self test ...] [:if test [:do ...]])
:byte! (lambda [self ref value] [:set! [:byte-at ref] value])
:word! (lambda [self ref value] [:set! [:word-at ref] value])
:long! (lambda [self ref value] [:set! [:long-at ref] value])
:data (lambda [self bytes]
(print "data" bytes (self:defining?))
(if (self:defining?) (let [name (self:gensym)] (self:expr-poly [:buffer name bytes]) name)
bytes))
:pstr (lambda [self str] [:data (.. (string.char (length str)) str)]) ; pascal-style
:cstr (lambda [self str] [:data (.. str "\x00")]) ; c-style
})
(fn Ssc.local-offset [self name-or-index]
(var offset nil)
(var stacklen 0)
(when self.locals
(for [i 1 (length self.locals)]
(let [loc (. self.locals i)
size (match loc.type :placeholder 0 :word 2 :long 4 _ (error (.. "how big is this local??" (fv loc))))]
(set stacklen (+ stacklen size))
(when (or (= i name-or-index) (= loc.name name-or-index))
(set offset stacklen)))))
(when offset (+ (- stacklen offset) 1)))
(fn Ssc.local-type [self name-or-index]
(var etype nil)
(for [i 1 (length self.locals)]
(when (or (= i name-or-index) (= (. self.locals i :name) name-or-index))
(set etype (. self.locals i :type))))
etype)
(fn Ssc.type-expr [self expr] (let [(_ etype) (self:expr-poly expr)] etype))
; opgen - a small structure that allows for reading a value with many different addressing modes
; :lo and :hi keys are functions that, when called with an opcode, returns that opcode with the appropriate argument to work on
; either the low or high word. If :hi does not exist in the structure, then the value represented by the opgen is only word-sized.
; :setup and :cleanup keys are used by push-opgen to handle generation of the necessary stack manipulation instructions.
; opgen-const makes the constant available in the :const key so it can be checked and potentially optimized further (+1 -> inc)
(fn Ssc.opgen-const [self const]
{:lo #[$1 (bit.band const 0xffff)] :hi (let [hi (bit.rshift (bit.band const 0xffff0000) 16)] (if (or (= hi 0) (= hi 0xffff)) nil #[$1 hi])) : const})
(fn Ssc.opgen-local [self loc]
{:lo #[$1 (self:local-offset loc) :s] :hi (when (= (self:local-type loc) :long) #[$1 (+ (self:local-offset loc) 2) :s])})
(fn Ssc.opgen-symbol [self name etype]
(if (= etype :byte) {:lo #[:block [:sep 0x30] [$1 name] [:rep 0x30] (when (= $1 :lda) [:and 0xff])]}
{:lo #[$1 name] :hi (when (= etype :long) #[$1 {:abs #(+ ($1:lookup-addr name) 2)}])}))
(fn Ssc.opgen-global [self name] (self:opgen-symbol name (. self.globals name :type)))
(fn Ssc.opgen-ref-loc [self name etype]
(when (= (self:local-type name) :word) ; long pointer deref is not possible directly from the stack; have to eval and move to LONG register
{:lo #[:block [:ldy 0] [$1 [(self:local-offset name) :s] :y]]
:hi (when (= etype :long) #[:block [:ldy 2] [$1 [(self:local-offset name) :s] :y]])}))
(fn Ssc.opgen-lhs [self expr]
(match [(type expr) expr]
[:string _] (if (self:local-offset expr) (self:opgen-local expr)
(. self.globals expr) (self:opgen-global expr))
(where [_ [type-at [:ref name]]] (string? name) (xxxx-at type-at)) (self:opgen-symbol name (xxxx-at type-at))
(where [_ [type-at name]] (string? name) (xxxx-at type-at) (self:local-offset name)) (self:opgen-ref-loc name (xxxx-at type-at))))
(fn Ssc.opgen [self expr]
(if (= (type expr) :number) (self:opgen-const expr)
(self:opgen-lhs expr)))
(fn Ssc.push-opgen [self expr]
(or (self:opgen expr)
(let [c (self:push nil expr)
iloc (length self.locals)]
(lume.merge (self:opgen-local iloc) {:setup #c :cleanup #(self:drop)}))))
(fn Ssc.expr-opgen [self expr ?expected-etype]
(var opgen (self:opgen expr))
(when (not opgen)
(let [(c-expr etype) (self:expr-poly expr)]
(set opgen (match etype
:word {:setup #c-expr :lo #[:flatten]}
:long {:setup #c-expr :lo #[$1 self.LONG_LO] :hi #[$1 self.LONG_HI]}))))
(when (and (= ?expected-etype :long) (= opgen.hi nil)) (set opgen.hi #[$1 0]))
(when (and ?expected-etype (= opgen nil)) (error (.. "Expected " ?expected-etype ", got void")))
(when (and (= ?expected-etype :word) opgen.hi) (error (.. "Expected word, got long")))
opgen)
(fn Ssc.parse-parameters [self params]
(icollect [_ param (ipairs params)] (match param
[:long pname] {:name pname :type :long}
pname {:name pname :type :word})))
(fn Ssc.push-arguments [self paramdefs args]
(icollect [iarg arg (ipairs args)]
(let [atype (. paramdefs iarg :type)
c-push (self:push nil arg atype)]
c-push)))
(fn Ssc.compile-function-call [self f args]
(let [pre (self:push-arguments f.args args)
locals (lume.clone self.locals)
callid (or (. self.callsites f.name) 0)
_ (tset self.callsites f.name (+ callid 1))
funcname self.defining-fn
callsite-sym (.. "<callsite " funcname " " f.name ":" callid ">")
capture-addr (fn [addr] (tset self.addr-to-callsite (- addr 1) {: callsite-sym : locals : funcname :calling f.name}))
post (icollect [_ (countiter (length args))] (self:drop))]
(values (lume.concat [:block] pre [[f.call-instruction f.name] callsite-sym [:export callsite-sym] [:meta capture-addr]] post) f.type)))
(fn Ssc.enter-expr [self expr]
(let [m (getmetatable expr)]
(when (and m m.filename) (set self.expr-metadata m))))
(fn Ssc.expr-expand [self expr]
(let [mt (getmetatable expr)
expanded (match expr
(where c (. self.constants c)) (self:expr-expand (. self.constants c))
(where [m & args] (. self.macros m)) (self:expr-expand ((. self.macros m) self (table.unpack args)))
(where [f & args] (not (. self.macrobarriers f))) (lume.concat [f] (icollect [_ arg (ipairs args)] (self:expr-expand arg)))
_ expr)
_ (when (= (type expanded) :table) (setmetatable expanded mt))]
expanded))
(fn Ssc.expr-poly [self expr]
(self:enter-expr expr)
(let [meta (or self.expr-metadata {:filename "<unknown>" :line "??"})
expr (self:expr-expand expr)
(success c-expr etype)
(pcall #(match expr
(where lit (?. (self:opgen lit) :hi)) (let [{: lo : hi} (self:opgen lit)]
(values [:block (lo :lda) [:sta self.LONG_LO] (hi :lda) [:sta self.LONG_HI]] :long))
(where lit (?. (self:opgen lit) :lo)) (let [{: lo} (self:opgen lit)] (values (lo :lda) :word))
(where [func & args] (= (?. self.functions func :arity) (length args)))
(self:compile-function-call (. self.functions func) args)
(where [form & args] (. self.forms form))
(let [f (. self.forms form)
(cexpr etype) (f self (table.unpack args))]
(values cexpr (or etype :word)))
nil (values [:block] :void)
_ (error (.. "Unrecognized expression"))))]
(if success (do (when (and c-expr (= (getmetatable c-expr) nil)) (setmetatable c-expr meta))
(values c-expr etype))
(let [{: filename : line} meta] (error (.. filename "@" line ": " c-expr "\n" (fv expr)))))))
(fn Ssc.expr-word [self expr]
(let [(c etype) (self:expr-poly expr)]
(when (not= etype :word) (error (.. "Unexpected long or void in " (fv expr) " - please wrap in explicit truncation form")))
c))
(fn Ssc.expr-long [self expr]
(let [(c etype) (self:expr-poly expr)]
(match etype
:long c
:word [:block c [:sta self.LONG_LO] [:lda 0] [:sta self.LONG_HI]]
_ (error (.. "Unexpected type " (fv etype) " in " (fv expr) " - wanted long or word")))))
(fn Ssc.compile [self ...]
(for [i 1 (select :# ...)]
(self:expr-poly (select i ...)))
self)
(fn Ssc.assemble [self]
(self.prg:assemble)
(set self.prg.source self)
self.prg)
(fn Ssc.read-hotswap [self machine prg-new]
(local {: hotswap-stacks} (require :ssc.hotswap))
(hotswap-stacks machine self prg-new.source))
Ssc

31
ssc/macros.fnl Normal file
View file

@ -0,0 +1,31 @@
; Sufficiently Simple Syntax macro
; This is basically just a quote that converts fennel syntax to Lua tables.
; Turns symbols into strings and lists into table literals. Table literals can be used to escape into regular fennel.
; Examples:
; (let (x 1 y 2) (+ "x" :y))
; => [:let [:x 1 :y 2] [:+ :x :y]]
; (form mymacro [(fn [ssc] (ssc:compile-expr [:+ 1 2]))])
; => [:form :mymacro (fn [ssc] (ssc:compile-expr [:+ 1 2]))]
(fn attach-metadata [form result]
(if (list? form)
(let [{: filename : line : bytestart : byteend} form]
`(setmetatable ,result ,{: filename : line : bytestart : byteend}))
result))
(fn form-to-fnl [form]
(attach-metadata form
(if (sym? form) (tostring form)
(sequence? form) (. form 1) ; escape
(list? form) (icollect [_ inner-form (ipairs form)] (form-to-fnl inner-form))
form)))
(fn sss [...]
(let [result `(values)]
(for [i 1 (select :# ...)]
(table.insert result (form-to-fnl (select i ...))))
result))
(fn compile [ssc ...] `(: ,ssc :compile ,(sss ...)))
{: sss : form-to-fnl : compile}

6
ssc/notes.txt Normal file
View file

@ -0,0 +1,6 @@
- Could custom forms compile to opgens?? What would this look like?
* see far-ref - it's really a constant, there's no reason to stuff the result into the temporary register just to push it onto the stack
* if you call expr-poly / expr-word / expr-long, then put it into the register
* but if you call expr-opgen, just return it! (opgen.setup) returns the appropriate code if needed
* toolbox calls could actually benefit from this! function calls, not so much
* currently expr-opgen is assumed to not have a cleanup step - this could complicate things

17
ssc/stdlib.fnl Normal file
View file

@ -0,0 +1,17 @@
(import-macros {:sss ! : compile} :ssc.macros)
#(compile $1
(fn memcpy ((long src) (long dst) count)
(let (bank (| (hiword dst) (byteswap (hiword src))))
(asm (lda bank)
(sta [{:abs #(+ ($1:lookup-addr :inst) 1)}])
(lda src) (tax)
(lda dst) (tay)
(lda count)
(dec)
(phb)
inst
(mvn 0 0)
(plb))))
)

58
ssc/task.fnl Normal file
View file

@ -0,0 +1,58 @@
(import-macros {:sss ! : compile} :ssc.macros)
(local {: addr-parser} (require :asm.65816))
#(compile $1
[(do (set $1.TASK-NEXT ($1:alloc-dp-var))
(set $1.TASK-STACK ($1:alloc-dp-var))
(set $1.TASK-MAILBOX ($1:alloc-dp-var))
nil)]
(global word old-dp 0)
(global word old-sp 0)
(form save-dp-sp [#[:block [:tdc] [:sta :old-dp] [:tsc] [:sta :old-sp]]])
(form restore-dp-sp [#[:block [:lda :old-dp] [:tcd] [:lda :old-sp] [:tcs]]])
(form save-6502-stack [#[:block [:tsc] [:tay] [:and 0xff] [:ora 0x100] [:tax] [:eor 0xffff] [:clc] [:adc 0x200] [:phb] [:mvn 0 0] [:plb]]])
(form restore-6502-stack [#[:block [:tsc] [:tax] [:and 0xff] [:ora 0x100] [:tay] [:eor 0xffff] [:clc] [:adc 0x200] [:phb] [:mvn 0 0] [:plb]]])
; 0x1ef = 0x1ef-0x1ff = 0x0f -> 0x7f
(define task-size 0x100)
(global word first-task)
(global word last-task)
(form set-task-base [(fn [ssc task-base]
[:block [:lda task-base] [:tcd]
[:sta ssc.TASK-NEXT] [:sta :first-task] [:sta :last-task]
[:tsc] [:and 0xff] [:ora task-base] [:tcs]])])
(fn yield ()
(asm (tsc) (sta [$1.TASK-STACK]) ;
debug-stub on-hotswap (export debug-stub) (export on-hotswap) ; todo: cleanup mame hotswap logic
(lda [$1.TASK-NEXT]) (tcd)
(lda [$1.TASK-STACK]) (tcs)))
(fn yield-forever () (while true (yield)))
(fn reset-task (task f)
; setup stack
(word! (long (+ task 0xfe)) (- (ref yield-forever) 1)) ; allow tasks to return; rts adds one to the value on the stack for the next pc
(word! (long (+ task 0xfc)) (- f 1)) ; yield will return to this address
(word! (long (+ task [(addr-parser $1.TASK-STACK)])) (+ task 0xfb)) ; stack pointer is the next available location
(word! (long (+ task [(addr-parser $1.TASK-MAILBOX)])) 0) ; clear mailbox
)
(fn new-task (f)
(let (next-task (+ last-task task-size))
(reset-task next-task f)
(word! (long (+ next-task [(addr-parser $1.TASK-NEXT)])) first-task) ; the last task yields to the first task, round-robin
(word! (long (+ last-task [(addr-parser $1.TASK-NEXT)])) next-task) ; the previously-last task now yields to us
(set! last-task next-task)
next-task))
(form current-task [#[:tdc]])
(fn task-send (task msg)
(word! (long (+ task [(addr-parser $1.TASK-MAILBOX)])) msg))
(form task-peek [#[:lda $1.TASK-MAILBOX]])
(fn task-recv ()
(asm (ldx [$1.TASK-MAILBOX]) (lda 0) (sta [$1.TASK-MAILBOX]) (txa))))

View file

@ -4,9 +4,9 @@
; git-subrepo command. See https://github.com/git-commands/git-subrepo#readme
;
[subrepo]
remote = https://github.com/jeremypenner/lite.git
remote = git@github.com:jeremypenner/lite
branch = master
commit = 2783adc10c2f42beefdbc7f19cec8971e4e9bb80
parent = dab1881d90ab1514301a081a9dbc265325672b20
commit = 384d54f9e343af74993766e6cedcf1498c5fdba6
parent = 3a4d6ff460eb0bc473ad779bc05a7d0153dc1ca7
method = merge
cmdver = 0.4.2
cmdver = 0.4.3

View file

@ -17,7 +17,7 @@ end
function strict.__index(t, k)
if not strict.defined[k] then
if not strict.defined[k] and k ~= nil then
error("cannot get undefined variable: " .. k, 2)
end
end

View file

@ -10,6 +10,8 @@
(local translate (require :core.doc.translate))
(local files (require :game.files))
(setmetatable _G nil)
(command.add nil {
"honeylisp:open-project" (fn []
(core.command_view:enter "Open Project"
@ -23,6 +25,14 @@
(table.insert files item.filename)))
(common.fuzzy_match files text))))})
(fn selected-symbol []
(local ldoc core.active_view.doc)
(var (aline acol bline bcol) (ldoc:get_selection))
(when (and (= aline bline) (= acol bcol))
(set (aline acol) (translate.start_of_word ldoc aline acol))
(set (bline bcol) (translate.end_of_word ldoc bline bcol)))
(ldoc:get_text aline acol bline bcol))
(command.add #(link.machine:connected?) {
"honeylisp:upload" (fn []
(local p (util.reload "game"))
@ -48,18 +58,20 @@
(editor.inline-eval vm-eval))
})
(command.add #(and (link.machine:connected?) link.machine.set-bp) {
"honeylisp:set-breakpoint" (fn []
(local word (selected-symbol))
(local p (require "game"))
(local addr (p:lookup-addr word))
(if addr (do (link.machine:set-bp addr)
(core.log (.. "Set breakpoint at " addr)))
(core.log (.. "Unknown address for " word))))
})
(command.add (fn [] true) {
"honeylisp:rebuild" #(util.reload "game")
})
(fn selected-symbol []
(local ldoc core.active_view.doc)
(var (aline acol bline bcol) (ldoc:get_selection))
(when (and (= aline bline) (= acol bcol))
(set (aline acol) (translate.start_of_word ldoc aline acol))
(set (bline bcol) (translate.end_of_word ldoc bline bcol)))
(ldoc:get_text aline acol bline bcol))
(command.add "core.docview" {
"fennel:eval" #(editor.inline-eval #(fv (fennel.eval $1 {:env _G :compiler-env _G}) {}))
"lume:hotswap" (fn []
@ -83,6 +95,7 @@
"alt+v" "honeylisp:vm-eval"
"alt+r" "lume:hotswap"
"alt+a" "honeylisp:address"
"alt+b" "honeylisp:set-breakpoint"
"alt+l" "honeylisp:reload"
})