SpindleyQ/honeylisp
1
1
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Compare commits

base: SpindleyQ:main
Branches Tags
SpindleyQ:main
SpindleyQ:nabu
SpindleyQ:gs
SpindleyQ:lazy-macro
SpindleyQ:kfest2021
SpindleyQ:projects
SpindleyQ:springlispjam2021
..
compare: SpindleyQ:springlispjam2021
Branches Tags
SpindleyQ:nabu
SpindleyQ:gs
SpindleyQ:lazy-macro
SpindleyQ:main
SpindleyQ:kfest2021
SpindleyQ:projects
SpindleyQ:springlispjam2021

No commits in common. "main" and "springlispjam2021" have entirely different histories.
main ... springlisp

68 changed files with 152 additions and 2440 deletions
Show stats Expand all files Collapse all files

BIN
8Bitsy.dsk
View file

Binary file not shown.

BIN
NeutTower.dsk
View file

Binary file not shown.

1
bitsy/game.json
View file

File diff suppressed because one or more lines are too long

60
bitsy/init.fnl
View file

@ -1,60 +0,0 @@
(local util (require :lib.util))
(local {: lo : hi : readjson} util)
(local tile (util.reload :game.tiles))
(local {: prg : vm : org : deflevel} (util.reload :bitsy.defs))
(local files (require :game.files))
(local disk (util.reload :bitsy.disk))
(util.reload :bitsy.gfx)
(util.reload :bitsy.footer)
(util.reload :bitsy.map)
(util.reload :bitsy.entity)
(util.reload :bitsy.player)
(util.reload :bitsy.boop)
(tile.appendtiles org.code)
(org.code:append [:align 0x100] :font)
(tile.appendgfx org.code files.game.font)
(tile.append-portraitwords vm)
(vm:var :tick-count)
(vm:word :handle-key :tick :read-key :player-key :hide-footer)
(vm:word :tick :map-specific-tick :tick-count :get 1 :+ :tick-count :set :player-redraw :rnd :drop)
(vm:var :next-level 0)
(vm:word :load-next-level :next-level :get :dup (vm:if [:load-level 0 :next-level :set] [:drop]))
(vm:word :load-level ; level-ptr --
:lit :map-ptr :set :reload-level)
(vm:word :reload-level
:map-player-yx :player-yx :set
:map-specific-load
:full-redraw)
(each [_ flag (ipairs (or files.game.flags []))]
(vm:var (.. :cond-var- flag) vm.false)
(vm:word (.. :cond- flag) (.. :cond-var- flag) :get))
(each [imap _ (ipairs files.game.levels)]
(deflevel imap (.. :map imap)))
(vm.code:append :main
[:jsr :reset]
[:jsr :interpret]
[:vm :hires
:lit :map1 :load-level
(vm:forever
(vm:hotswap-sync :full-redraw)
:interactive-eval-checkpoint
:handle-key
)
:quit])
(disk.append-boot-loader prg)
(print "assembling")
(prg:assemble)
(print "assembled")
(disk.write prg)
prg

12
editor/8bitsy.fnl
View file

@ -22,7 +22,7 @@
(util.nested-tset action [:lines 4] (line4:sub 1 33)) (util.nested-tset action [:lines 4] (line4:sub 1 33))
y)) y))
(fn [action vm] (fn [action vm]
(local {: say} (require :bitsy.defs)) (local {: say} (require :game.defs))
(say action.character (table.unpack (lume.map action.lines #($1:upper)))))) (say action.character (table.unpack (lume.map action.lines #($1:upper))))))
(actions.register :warp (actions.register :warp
@ -30,8 +30,8 @@
(let [maps (icollect [imap _ (ipairs files.game.levels)] (.. :map imap)) (let [maps (icollect [imap _ (ipairs files.game.levels)] (.. :map imap))
map (or action.map (. maps 1)) map (or action.map (. maps 1))
y (+ y style.padding.y) y (+ y style.padding.y)
map (dropdown view [:warp :map i] map maps x y (* 100 SCALE)) map (dropdown view [:warp :map i] map maps x y 100)
(position-string y) (textbox view [:warp :loc i] (string.format "%x" (or action.position 0)) (+ x (* 150 SCALE)) y (* 150 SCALE)) (position-string y) (textbox view [:warp :loc i] (string.format "%x" (or action.position 0)) (+ x 150) y 150)
position (or (tonumber position-string 16) action.position)] position (or (tonumber position-string 16) action.position)]
(set action.map map) (set action.map map)
(set action.position position) (set action.position position)
@ -47,13 +47,13 @@
(let [y (+ y style.padding.y) (let [y (+ y style.padding.y)
x (renderer.draw_text style.font "Set " x y style.text) x (renderer.draw_text style.font "Set " x y style.text)
flag (or action.flag (. files.game.flags 1)) flag (or action.flag (. files.game.flags 1))
flag (dropdown view [:set-flag :flag i] flag files.game.flags x y (* 100 SCALE)) flag (dropdown view [:set-flag :flag i] flag files.game.flags x y 100)
x (renderer.draw_text style.font " to " (+ x (* 100 SCALE)) y style.text) x (renderer.draw_text style.font " to " (+ x 100) y style.text)
options (lume.concat options (lume.concat
[{:label "<Yes>" :value 0xffff} {:label "<No>" :value 0}] [{:label "<Yes>" :value 0xffff} {:label "<No>" :value 0}]
(icollect [_ flag (ipairs files.game.flags)] {:label flag :value (.. :cond- flag)})) (icollect [_ flag (ipairs files.game.flags)] {:label flag :value (.. :cond- flag)}))
rhs (or action.rhs (. options 1)) rhs (or action.rhs (. options 1))
(rhs y) (dropdown view [:set-flag :rhs i] rhs options x y (* 100 SCALE))] (rhs y) (dropdown view [:set-flag :rhs i] rhs options x y 100)]
(set action.flag flag) (set action.flag flag)
(set action.rhs rhs) (set action.rhs rhs)
y)) y))

15
editor/imstate.fnl
View file

@ -95,18 +95,17 @@
(activate view tag x y w h) (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))) (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] (fn textbutton [view label x y]
(let [font (or ?font style.font)] (local (w h) (values (+ (style.font:get_width label) style.padding.x) (+ (style.font:get_height) style.padding.y)))
(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_rect x y w h style.selection)
(renderer.draw_text font label (+ x (/ style.padding.x 2)) (+ y (/ style.padding.y 2)) style.text) (renderer.draw_text style.font label (+ x (/ style.padding.x 2)) (+ y (/ style.padding.y 2)) style.text)
(values (button view label x y w h) (+ y h)))) (values (button view label x y w h) (+ y h)))
(fn checkbox [view name isset x y ?tag] (fn checkbox [view name isset x y ?tag]
(love.graphics.rectangle (if isset :fill :line) x y (* 12 SCALE) (* 12 SCALE)) (love.graphics.rectangle (if isset :fill :line) x y 12 12)
(local xEnd (renderer.draw_text style.font name (+ x (* 16 SCALE)) y style.text)) (local xEnd (renderer.draw_text style.font name (+ x 16) y style.text))
(love.graphics.setColor 1 1 1 1) (love.graphics.setColor 1 1 1 1)
(button view (or ?tag name) x y (- xEnd x) (* 12 SCALE))) (button view (or ?tag name) x y (- xEnd x) 12))
(fn focused? [view tag] (= (make-tag tag) (-?> view.imstate.focus (. :tag)))) (fn focused? [view tag] (= (make-tag tag) (-?> view.imstate.focus (. :tag))))
(fn focus [view tag x y w h opts] (fn focus [view tag x y w h opts]

3
editor/init.fnl
View file

@ -10,7 +10,6 @@
(local common (require :core.common)) (local common (require :core.common))
(require :editor.8bitsy) (require :editor.8bitsy)
(require :presentation.commands)
(let [commands {}] (let [commands {}]
(each [_ name (ipairs [:tile :portrait :font :brush :map])] (each [_ name (ipairs [:tile :portrait :font :brush :map])]
@ -21,7 +20,7 @@
(command.add nil commands)) (command.add nil commands))
(local fileeditors (local fileeditors
{:screen {:view ScreenEditView :filefilter ".*%.screen"}}) {:screen {:view ScreenEditView :filefilter "^game/.*%.screen"}})
(each [type {: view : filefilter} (pairs fileeditors)] (each [type {: view : filefilter} (pairs fileeditors)]
(command.add nil (command.add nil

68
editor/mapedit.fnl
View file

@ -66,7 +66,7 @@
level-count (length files.game.levels) level-count (length files.game.levels)
_ (do (for [i 1 level-count] (tset options i i)) _ (do (for [i 1 level-count] (tset options i i))
(table.insert options :New)) (table.insert options :New))
(ilevel yNext) (dropdown self :map-selector self.ilevel options (+ x (* 50 SCALE)) y (* 100 SCALE))] (ilevel yNext) (dropdown self :map-selector self.ilevel options (+ x 50) y 100)]
(when (not= ilevel self.ilevel) (when (not= ilevel self.ilevel)
(set self.ilevel (if (= ilevel :New) (+ level-count 1) ilevel)) (set self.ilevel (if (= ilevel :New) (+ level-count 1) ilevel))
(self:load-level)) (self:load-level))
@ -93,7 +93,7 @@
(var stripid "") (var stripid "")
(for [mx 1 mapw] (for [mx 1 mapw]
(local itile (self:itile-from-xy mx my)) (local itile (self:itile-from-xy mx my))
(local tile (?. self.tilecache.tiles itile :gfx)) (local tile (. self.tilecache.tiles itile :gfx))
(table.insert tilestrip tile) (table.insert tilestrip tile)
(set stripid (.. stripid (string.char itile)))) (set stripid (.. stripid (string.char itile))))
(var sprite (. self.stripcache stripid)) (var sprite (. self.stripcache stripid))
@ -115,7 +115,7 @@
(local itile (self:itile-from-xy mx my)) (local itile (self:itile-from-xy mx my))
(local iobject (self:iobject-from-xy mx my)) (local iobject (self:iobject-from-xy mx my))
(when (= self.itile nil) (when (= self.itile nil)
(each [_ player (ipairs (or files.game.players [:player]))] (let [player :player]
(match (. self.level player) (match (. self.level player)
{:x mx :y my} (renderer.draw_text style.font player tilex tiley style.text))) {:x mx :y my} (renderer.draw_text style.font player tilex tiley style.text)))
(love.graphics.setColor 1 1 1)) (love.graphics.setColor 1 1 1))
@ -170,44 +170,38 @@
(var istep-to-delete nil) (var istep-to-delete nil)
(when (not object.steps) (set object.steps [])) (when (not object.steps) (set object.steps []))
(each [istep step (ipairs object.steps)] (each [istep step (ipairs object.steps)]
(when (textbutton self "X" (+ x (* 280 SCALE)) y) (when (textbutton self "X" (+ x 280) y)
(set istep-to-delete istep)) (set istep-to-delete istep))
(set step.condition (. (dropdown self [:code-condition istep] (condition-label step.condition) (condition-options) (set step.condition (. (dropdown self [:code-condition istep] (condition-label step.condition) (condition-options)
(+ x (* 100 SCALE) style.padding.x) y (* 100 SCALE)) (+ x 100 style.padding.x) y 100)
:flag)) :flag))
(set (step.action y) (dropdown self [:code-action istep] (or step.action (. actions.actionlist 1)) actions.actionlist x y (* 100 SCALE))) (set (step.action y) (dropdown self [:code-action istep] (or step.action (. actions.actionlist 1)) actions.actionlist x y 100))
(set y (actions.edit step self x y (* 300 SCALE) istep)) (set y (actions.edit step self x y 300 istep))
(set y (+ y style.padding.y))) (set y (+ y style.padding.y)))
(when istep-to-delete (table.remove object.steps istep-to-delete)) (when istep-to-delete (table.remove object.steps istep-to-delete))
(let [(do-new y) (textbutton self "+ New Step" x (+ y style.padding.y))] (let [(do-new y) (textbutton self "+ New Step" x (+ y style.padding.y))]
(when do-new (table.insert object.steps {})) (when do-new (table.insert object.steps {}))
y)) y))
(fn advanced? [object]
(or object.advanced
(and (= object.advanced nil)
(not= object.func "")
(not= object.func nil))))
(fn MapEditView.draw-object-advanced-editor [self object x y] (fn MapEditView.draw-object-advanced-editor [self object x y]
(let [(func y) (textfield self "Word" object.func x y (* 100 SCALE) (* 200 SCALE)) (let [(func y) (textfield self "Word" object.func x y 100 200)
(name y) (textfield self "Name" object.name x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE)) (name y) (textfield self "Name" object.name x (+ y style.padding.y) 100 200)
(linkword y) (textfield self "Link word" object.linkword x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE)) (linkword y) (textfield self "Link word" object.linkword x (+ y style.padding.y) 100 200)
(do-unlink y) (if object.link (textbutton self "Unlink" x (+ y style.padding.y)) (values false y)) (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)))] (linkentity y) (if object.link (values object.linkentity y) (textfield self "Link entity" object.linkentity x (+ y style.padding.y) 100 200))]
(lume.extend object {: func : name : linkword : linkentity}) (lume.extend object {: func : name : linkword : linkentity})
(when do-unlink (set object.link nil)) (when do-unlink (set object.link nil))
y)) y))
(fn MapEditView.draw-object-editor [self x y] (fn MapEditView.draw-object-editor [self x y]
(let [object (self:object) (let [object (self:object)
y (if (advanced? object) y (if object.advanced
(self:draw-object-advanced-editor object x y) (self:draw-object-advanced-editor object x y)
(self:draw-object-code-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)) new-flag-name (textbox self :new-flag-name self.new-flag-name x (+ y style.padding.y) 200)
(mk-new-flag y) (textbutton self "+ New Flag" (+ x (* 200 SCALE) style.padding.x) (+ y style.padding.y)) (mk-new-flag y) (textbutton self "+ New Flag" (+ x 200 style.padding.x) (+ y style.padding.y))
do-delete (textbutton self "Delete" x (+ y (* style.padding.y 2))) do-delete (textbutton self "Delete" x (+ y 40))
(do-advanced y) (textbutton self (if (advanced? object) "Simple" "Advanced") (+ x (* 150 SCALE)) (+ y (* style.padding.y 2)))] (do-advanced y) (textbutton self (if object.advanced "Simple" "Advanced") (+ x 150) (+ y 40))]
(set self.new-flag-name new-flag-name) (set self.new-flag-name new-flag-name)
(when mk-new-flag (when mk-new-flag
(when (= files.game.flags nil) (when (= files.game.flags nil)
@ -217,7 +211,7 @@
(when do-delete (when do-delete
(move-object self.level.objects (+ self.iobject 1) self.iobject) (move-object self.level.objects (+ self.iobject 1) self.iobject)
(set self.iobject nil)) (set self.iobject nil))
(when do-advanced (set object.advanced (not (advanced? object)))) (when do-advanced (set object.advanced (not object.advanced)))
y)) y))
(fn MapEditView.load-level [self] (fn MapEditView.load-level [self]
@ -237,37 +231,29 @@
(self:draw_background style.background) (self:draw_background style.background)
(self:draw_scrollbar) (self:draw_scrollbar)
(local ytop y) (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)) (set y (+ y (self:draw-map-selector x y) style.padding.y))
(self:draw-map-editor x y) (self:draw-map-editor x y)
(set y (+ y (* tileh maph) style.padding.y)) (set y (+ y (* tileh maph) style.padding.y))
(set y (+ y (self:draw-tile-selector x y (if editor-on-side (* tilew mapw) (set y (+ y (self:draw-tile-selector x y (- self.size.x (* style.padding.x 2)))))
(- 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.tickword y) (textfield self "Tick word" self.level.tickword x (+ y style.padding.y) 100 200))
(set (self.level.moveword y) (textfield self "Move word" self.level.moveword 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 200))
(set (self.level.loadword y) (textfield self "Load word" self.level.loadword 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 200))
(let [(checked y-new) (checkbox self "Edit objects" (= self.itile nil) x (+ y style.padding.y)) (let [(checked y-new) (checkbox self "Edit objects" (= self.itile nil) x (+ y style.padding.y))
_ (when checked _ (when checked
(set self.itile nil) (set self.itile nil)
(set self.playerpos nil))] (set self.playerpos nil))
(set y y-new) (checked y-new) (checkbox self (.. "Position " :player) (and (= self.itile nil) (= self.playerpos :player)) x (+ y-new style.padding.y))]
(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 (when checked
(set self.itile nil) (set self.itile nil)
(set self.playerpos player)) (set self.playerpos :player))
(set y y-new)))) (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 (when self.iobject
(set y (math.max y (if editor-on-side (set y (math.max y (if (> self.size.x (+ (* tilew mapw) 300))
(self:draw-object-editor (+ x (* tilew mapw) style.padding.x) ytop) (self:draw-object-editor (+ x (* tilew mapw) style.padding.x) ytop)
(self:draw-object-editor x (+ y style.padding.y)))))) (self:draw-object-editor x (+ y style.padding.y))))))
(set self.scrollheight (+ y (- self.position.y) self.scroll.y style.padding.y))) (set self.scrollheight (- y (+ self.position.y style.padding.y (- self.scroll.y)))))
(fn MapEditView.get_name [self] (.. "Map " self.ilevel)) (fn MapEditView.get_name [self] (.. "Map " self.ilevel))

3
editor/screenedit.fnl
View file

@ -88,7 +88,8 @@
(self:draw-screen-editor (+ self.position.x 10) (+ self.position.y 10)) (self:draw-screen-editor (+ self.position.x 10) (+ self.position.y 10))
(self:draw-tile-selector (+ self.position.x 10) (+ self.position.y 20 (* screenh screen-scale)) (- self.size.x 20))) (self:draw-tile-selector (+ self.position.x 10) (+ self.position.y 20 (* screenh screen-scale)) (- self.size.x 20)))
(fn ScreenEditView.resource-key [self] "brushes") (fn ScreenEditView.filename [self] "editor/brushes.json")
(fn ScreenEditView.spritegen [self] char-to-sprite)
(fn ScreenEditView.tilesize [self] (values 8 8)) (fn ScreenEditView.tilesize [self] (values 8 8))
(fn ScreenEditView.get_name [self] (.. "Screen: " self.screenfilename)) (fn ScreenEditView.get_name [self] (.. "Screen: " self.screenfilename))

19
editor/tileedit.fnl
View file

@ -1,7 +1,6 @@
(local GraphicsEditView (require :editor.gfxedit)) (local GraphicsEditView (require :editor.gfxedit))
(local style (require :core.style)) (local style (require :core.style))
(local tiles (require :game.tiles)) (local tiles (require :game.tiles))
(local files (require :game.files))
(local tiledraw (require :editor.tiledraw)) (local tiledraw (require :editor.tiledraw))
(local util (require :lib.util)) (local util (require :lib.util))
(local {: mouse-inside : activate : active? : checkbox : textfield} (util.require :editor.imstate)) (local {: mouse-inside : activate : active? : checkbox : textfield} (util.require :editor.imstate))
@ -21,9 +20,7 @@
(values ibyte ibit))) (values ibyte ibit)))
(fn TileView.tilesize [self] (values 16 16)) (fn TileView.tilesize [self] (values 16 16))
(fn TileView.tilekeys [self] (fn TileView.tilekeys [self] [:gfx])
(if files.game.tilesets (icollect [_ key (pairs files.game.tilesets)] key)
[:gfx]))
(fn get-byte [tile ibyte] (fn get-byte [tile ibyte]
(: (tile:sub (+ ibyte 1) (+ ibyte 1)) :byte)) (: (tile:sub (+ ibyte 1) (+ ibyte 1)) :byte))
@ -74,18 +71,16 @@
(fn TileView.draw-tile-flag [self flagname x y] (fn TileView.draw-tile-flag [self flagname x y]
(local flags (-?> self.tilecache.tiles (. self.itile) (. :flags))) (local flags (-?> self.tilecache.tiles (. self.itile) (. :flags)))
(local flagset (if flags (. flags flagname) false)) (local flagset (if flags (. flags flagname) false))
(let [(checked yNew) (checkbox self flagname flagset x y)] (when (checkbox self flagname flagset x y)
(when checked (tset flags flagname (if flagset nil true))) (tset flags flagname (if flagset nil true))))
yNew))
(fn TileView.draw-tile-flags [self x y] (fn TileView.draw-tile-flags [self x y]
(local tile (-?> self.tilecache.tiles (. self.itile))) (local tile (-?> self.tilecache.tiles (. self.itile)))
(var y y)
(when tile (when tile
(set (tile.word y) (textfield self "Default word" tile.word x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE))) (set tile.word (textfield self "Default word" tile.word x y 100 200))
(set (tile.label y) (textfield self "Label" tile.label x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE)))) (set tile.label (textfield self "Label" tile.label x (+ y pixel-size 4) 100 200)))
(each [iflag flagname (ipairs (tiles.flags))] (each [iflag flagname (ipairs tiles.flags)]
(set y (self:draw-tile-flag flagname x (+ y style.padding.y))))) (self:draw-tile-flag flagname x (+ y (* (+ iflag 1) (+ pixel-size 4))))))
(fn TileView.update-tile [self newtile] (fn TileView.update-tile [self newtile]
(self.tilecache:update-tile self.itile newtile self.tilekey)) (self.tilecache:update-tile self.itile newtile self.tilekey))

2
bitsy/boop.fnl → game/boop.fnl
View file

@ -1,4 +1,4 @@
(local {: vm} (require :bitsy.defs)) (local {: vm} (require :game.defs))
(local speaker :0xc030) (local speaker :0xc030)
(vm:def :blipmem ; count p -- (vm:def :blipmem ; count p --

2
bitsy/defs.fnl → game/defs.fnl
View file

@ -154,7 +154,7 @@
(local level prg) ; todo: (asm.new prg) - if we want to load levels as an overlay (local level prg) ; todo: (asm.new prg) - if we want to load levels as an overlay
(local org level.vm.code) ; (level:org org.level.org) - if we want to give level data a stable loxation (local org level.vm.code) ; (level:org org.level.org) - if we want to give level data a stable loxation
(local map (. files.game.levels ilevel)) (local map (. files.game.levels ilevel))
(local entity (require :bitsy.entity)) (local entity (require :game.entity))
(append-map map org label) (append-map map org label)
(entity.append-from-map map org label) (entity.append-from-map map org label)
(set level.vm.code org) (set level.vm.code org)

2
bitsy/disk.fnl → game/disk.fnl
View file

@ -3,7 +3,7 @@
(local Prodos (require :asm.prodos)) (local Prodos (require :asm.prodos))
(local util (require :lib.util)) (local util (require :lib.util))
(local {: lo : hi} util) (local {: lo : hi} util)
(local {: org} (require :bitsy.defs)) (local {: org} (require :game.defs))
(fn append-boot-loader [prg] (fn append-boot-loader [prg]
(local vm prg.vm) (local vm prg.vm)

2
bitsy/entity.fnl → game/entity.fnl
View file

@ -1,6 +1,6 @@
(local util (require :lib.util)) (local util (require :lib.util))
(local tiles (util.require :game.tiles)) (local tiles (util.require :game.tiles))
(local {: vm : org : itile : say : say-runon : controlstate} (require :bitsy.defs)) (local {: vm : org : itile : say : say-runon : controlstate} (require :game.defs))
(local {: lo : hi} util) (local {: lo : hi} util)
; Entity memory layout: ; Entity memory layout:

49
game/files.fnl
View file

@ -4,7 +4,8 @@
(local files (util.hot-table ...)) (local files (util.hot-table ...))
(local default-filename "bitsy/game.json") (local filename "game/game.json")
(local encoded-tile-fields [:gfx :mask]) (local encoded-tile-fields [:gfx :mask])
(fn convert [tile field method] (fn convert [tile field method]
@ -12,30 +13,27 @@
(when oldval (when oldval
(tset tile field (: oldval method))) (tset tile field (: oldval method)))
tile) tile)
(fn convert-all [tile method root] (fn convert-all [tile method]
(let [encoded-tile-fields [:mask]]
(each [_ key (pairs (or root.tilesets {:tileset :gfx}))]
(table.insert encoded-tile-fields key))
(each [_ field (ipairs encoded-tile-fields)] (each [_ field (ipairs encoded-tile-fields)]
(convert tile field method)) (convert tile field method))
tile)) tile)
(fn tile-deserialize [tile root] (fn tile-deserialize [tile]
(match (type tile) (match (type tile)
:string {:gfx (tile:fromhex) :flags {}} :string {:gfx (tile:fromhex) :flags {}}
:table (convert-all tile :fromhex root))) :table (convert-all tile :fromhex)))
(fn tile-serialize [tile root] (convert-all (lume.clone tile) :tohex root)) (fn tile-serialize [tile] (convert-all (lume.clone tile) :tohex))
(fn deserialize [key value root] (fn deserialize [key value]
(match key (match key
(where (or :tiles :portraits :font :brushes)) (tile-deserialize value root) (where (or :tiles :portraits :font)) (tile-deserialize value)
:levels (do (set value.map (value.map:fromhex)) value) :levels (do (set value.map (value.map:fromhex)) value)
_ value)) _ value))
(fn serialize [key value root] (fn serialize [key value]
(match key (match key
(where (or :tiles :portraits :font :brushes)) (tile-serialize value root) (where (or :tiles :portraits :font)) (tile-serialize value)
:levels (do (set value.map (value.map:tohex)) value) :levels (do (set value.map (value.map:tohex)) value)
_ value)) _ value))
@ -44,29 +42,25 @@
:table (lume.clone v) :table (lume.clone v)
_ v)) _ v))
(fn filename [] (or files.filename default-filename)) (fn files.load []
(fn files.load [?filename]
(when ?filename (set files.filename ?filename))
(set files.game (set files.game
(if (util.file-exists (filename)) (if (util.file-exists filename)
(let [game (util.readjson (filename))] (let [game (util.readjson filename)]
(each [k v (pairs game)] (each [k v (pairs game)]
(tset game k (lume.map v #(deserialize k (clone $1) game)))) (tset game k (lume.map v #(deserialize k (clone $1)))))
game) game)
{:tiles [] :portraits [] :font [] :levels []})) {:tiles [] :portraits [] :font [] :levels []}))
files.game) files.game)
(fn files.save [?filename] (fn files.save []
(when ?filename (set files.filename ?filename))
(let [game {}] (let [game {}]
(each [k v (pairs files.game)] (each [k v (pairs files.game)]
(tset game k (lume.map v #(serialize k (clone $1) files.game)))) (tset game k (lume.map v #(serialize k (clone $1)))))
(util.writejson (filename) game))) (util.writejson filename game)))
(fn new-cache [game key] (fn new-cache [game key]
(let [spritegen (match key (let [spritegen (match key
:font tiledraw.char-to-sprite :font tiledraw.char-to-sprite
:brushes tiledraw.char-to-sprite
:portraits tiledraw.portrait-to-sprite :portraits tiledraw.portrait-to-sprite
_ tiledraw.tile-to-sprite) _ tiledraw.tile-to-sprite)
gfx (. game key)] gfx (. game key)]
@ -77,15 +71,12 @@
(util.nested-tset files [:tilecaches key] (new-cache files.game key))) (util.nested-tset files [:tilecaches key] (new-cache files.game key)))
(. files.tilecaches key)) (. files.tilecaches key))
(fn files.reload [?filename] (fn files.reload []
(files.load ?filename) (files.load)
(when files.tilecaches (when files.tilecaches
(each [key cache (pairs files.tilecaches)] (each [key cache (pairs files.tilecaches)]
(cache:load (. files.game key))))) (cache:load (. files.game key)))))
(fn files.module []
(or files.game.module (: (filename) :match "^[^/]+")))
(when (= files.game nil) (when (= files.game nil)
(files.load)) (files.load))

2
bitsy/footer.fnl → game/footer.fnl
View file

@ -1,4 +1,4 @@
(local {: vm : org} (require :bitsy.defs)) (local {: vm : org} (require :game.defs))
(local {: hi : lo} (require :lib.util)) (local {: hi : lo} (require :lib.util))
(vm:def :draw-pchar ; pscreen pchar -- (vm:def :draw-pchar ; pscreen pchar --

1
game/game.json Normal file
View file

File diff suppressed because one or more lines are too long

2
bitsy/gfx.fnl → game/gfx.fnl
View file

@ -1,5 +1,5 @@
(local {: lo : hi} (require :lib.util)) (local {: lo : hi} (require :lib.util))
(local {: vm : mapw : maph : org} (require :bitsy.defs)) (local {: vm : mapw : maph : org} (require :game.defs))
; Graphics routines ; Graphics routines
(vm:def :mixed [:sta :0xc053]) (vm:def :mixed [:sta :0xc053])

59
game/init.fnl
View file

@ -1,5 +1,60 @@
(local files (require :game.files))
(local util (require :lib.util)) (local util (require :lib.util))
(local {: lo : hi : readjson} util)
(local tile (util.reload :game.tiles))
(local {: prg : vm : org : deflevel} (util.reload :game.defs))
(local files (require :game.files))
(util.reload (files.module)) (local disk (util.reload :game.disk))
(util.reload :game.gfx)
(util.reload :game.footer)
(util.reload :game.map)
(util.reload :game.entity)
(util.reload :game.player)
(util.reload :game.boop)
(tile.appendtiles org.code)
(org.code:append [:align 0x100] :font)
(tile.appendgfx org.code files.game.font)
(tile.append-portraitwords vm)
(vm:var :tick-count)
(vm:word :handle-key :tick :read-key :player-key :hide-footer)
(vm:word :tick :map-specific-tick :tick-count :get 1 :+ :tick-count :set :player-redraw :rnd :drop)
(vm:var :next-level 0)
(vm:word :load-next-level :next-level :get :dup (vm:if [:load-level 0 :next-level :set] [:drop]))
(vm:word :load-level ; level-ptr --
:lit :map-ptr :set :reload-level)
(vm:word :reload-level
:map-player-yx :player-yx :set
:map-specific-load
:full-redraw)
(each [_ flag (ipairs (or files.game.flags []))]
(vm:var (.. :cond-var- flag) vm.false)
(vm:word (.. :cond- flag) (.. :cond-var- flag) :get))
(each [imap _ (ipairs files.game.levels)]
(deflevel imap (.. :map imap)))
(vm.code:append :main
[:jsr :reset]
[:jsr :interpret]
[:vm :hires
:lit :map1 :load-level
(vm:forever
(vm:hotswap-sync :full-redraw)
:interactive-eval-checkpoint
:handle-key
)
:quit])
(disk.append-boot-loader prg)
(print "assembling")
(prg:assemble)
(print "assembled")
(disk.write prg)
prg

2
bitsy/map.fnl → game/map.fnl
View file

@ -1,5 +1,5 @@
(local {: lo : hi} (require :lib.util)) (local {: lo : hi} (require :lib.util))
(local {: vm : mapw : maph : rot8l} (require :bitsy.defs)) (local {: vm : mapw : maph : rot8l} (require :game.defs))
(vm:def :lookup-flags ; itile -- flags (vm:def :lookup-flags ; itile -- flags
[:lda vm.TOP :x] [:lda vm.TOP :x]

4
bitsy/player.fnl → game/player.fnl
View file

@ -1,7 +1,7 @@
(local tile (require :game.tiles)) (local tile (require :game.tiles))
(local {: vm : mapw : maph : itile : controlstate} (require :bitsy.defs)) (local {: vm : mapw : maph : itile : controlstate} (require :game.defs))
(local {: walkable} (tile.flag-to-bit)) (local {: walkable} tile.flag-to-bit)
(vm:word :either= ; target val1 val2 -- f (vm:word :either= ; target val1 val2 -- f
:>rot :over := :>rot := :|) :>rot :over := :>rot := :|)

16
game/tiles.fnl
View file

@ -1,10 +1,10 @@
(local util (require :lib.util)) (local util (require :lib.util))
(local lume (require :lib.lume)) (local lume (require :lib.lume))
(local files (require :game.files)) (local files (require :game.files))
(local flags [:walkable])
(fn flags [] (or files.game.tileflags [:walkable])) (local flag-to-bit {})
(fn flag-to-bit [] (each [iflag flag (ipairs flags)]
(collect [iflag flag (ipairs (flags))] (values flag (bit.lshift 1 (- iflag 1))))) (tset flag-to-bit flag (bit.lshift 1 (- iflag 1))))
(fn appendgfx [org gfx ?key ?label-prefix] (fn appendgfx [org gfx ?key ?label-prefix]
(each [_ g (ipairs gfx)] (each [_ g (ipairs gfx)]
@ -13,16 +13,14 @@
(fn appendtiles [org] (fn appendtiles [org]
(local tiles files.game.tiles) (local tiles files.game.tiles)
(local flag-lookup (flag-to-bit)) (org:append [:align 0x100] :tileset)
(each [tileset key (pairs (or files.game.tilesets {:tileset :gfx}))] (appendgfx org tiles)
(org:append [:align 0x100] tileset)
(appendgfx org tiles key (if (= key :gfx) nil (.. key :-))))
(appendgfx org files.game.portraits nil :portrait-) (appendgfx org files.game.portraits nil :portrait-)
(org:append :tileflags) (org:append :tileflags)
(each [_ tile (ipairs tiles)] (each [_ tile (ipairs tiles)]
(var flags 0) (var flags 0)
(each [flag _ (pairs tile.flags)] (each [flag _ (pairs tile.flags)]
(set flags (bit.bor flags (. flag-lookup flag)))) (set flags (bit.bor flags (. flag-to-bit flag))))
(org:append [:db flags]))) (org:append [:db flags])))
(fn append-portraitwords [vm ?overrides] (fn append-portraitwords [vm ?overrides]

66
kfest2021.md
View file

@ -1,66 +0,0 @@
# Honeylisp
## Introduction
* 286 project
* Honeylisp vision
## Assembler
### What is an assembler?
* I _thought_ the hard part was going to be converting mnemonics to bytes
* Turns out the hard part is actually converting labels to bytes
* zero-page instructions are a different size!
### How it works
* Represent each opcode as a Fennel data literal
* nest blocks arbitrarily - "lexical scope"
* multi-pass
## VM
* Forth-ish stack machine
* "direct threaded" inner interpreter
* extend assembler with :vm directive
* "immediate words" are just Fennel functions
## Lite
* Minimal extensible text editor built in Lua
* love2d port
## Custom Editors
* imgui style
* show tile editor with map editor
* font + portrait editors based on tile editor
* generate bytes / code with fennel functions! (maps, gfx, etc)
## MAME Upload
* Nod to Dagen Brock's 2016 KFest talk on GSPlus https://www.youtube.com/watch?v=1LzCmpAanpE
* Integrated Jeejah networked REPL into MAME
* Can send arbitrary Fennel code to MAME to control it
* Poke blocks of memory over the network (nREPL uses bencode from bittorrent, which allows this to be fairly low overhead)
## Live Code Injection
* The assembled program is an object in memory, which we can extend interactively
* We can write new code and poke it into memory while the old code is running!
* Game code is a loop - we can have a "sync point" at the top of the loop where the state of the game is well-known
* (demo switching video modes, printing debug output, making sounds)
## Hot Reload
* Because the assembled program is an object in memory
## Tape generation
* Benefit of building tools in a game engine - I can just output audio
* Extended assembler to accept BASIC tokens and generate linked list of BASIC lines, so the whole thing could be bootstrapped
## Disk generation
* Take a ProDOS disk image, parse it, and add files to it
* Generate loader program, rest of game can be loaded as an overlay
* New disk image is generated on every build because why not? It's fast
## Neu] [ower
* Fun tricks: Random number generator (never used for gameplay purposes) = just dump a couple dozen random bytes
## 8-Bitsy
* Full "code-optional" environment
* Kind of awkward to actually use, but it works!
* Son drew some art
* Improvisational game design!

4
lib/lume.lua
View file

@ -624,7 +624,7 @@ function lume.wordwrap(str, limit)
check = limit check = limit
end end
local rtn = {} local rtn = {}
local line = str:match("^(%s*)") local line = ""
for word, spaces in str:gmatch("(%S+)(%s*)") do for word, spaces in str:gmatch("(%S+)(%s*)") do
local s = line .. word local s = line .. word
if check(s) then if check(s) then
@ -694,7 +694,7 @@ function lume.hotswap(modname)
local oldmt, newmt = getmetatable(old), getmetatable(new) local oldmt, newmt = getmetatable(old), getmetatable(new)
if oldmt and newmt then update(oldmt, newmt) end if oldmt and newmt then update(oldmt, newmt) end
for k, v in pairs(new) do for k, v in pairs(new) do
if type(v) == "table" and type(old[k]) == "table" then update(old[k], v) else old[k] = v end if type(v) == "table" then update(old[k], v) else old[k] = v end
end end
end end
local err = nil local err = nil

86
neuttower/boop.fnl
View file

@ -1,86 +0,0 @@
(local {: vm} (require :neuttower.defs))
(local speaker :0xc030)
(vm:def :blipmem ; count p --
[:block
[:lda [vm.ST1 :x]]
[:tay]
:sample
[:lda speaker]
[:lda [vm.TOP :x]]
[:inc vm.TOP :x]
[:bne :wait]
[:inc vm.TOPH :x]
:wait
[:clc] [:adc 1]
[:bne :wait]
[:dey]
[:bne :sample]]
(vm:drop) (vm:drop))
(vm:def :bliptone ; duration-f1 f2 --
[:block
[:lda vm.ST1H :x]
[:sta vm.W]
:top
[:lda speaker]
[:ldy vm.ST1 :x]
:wave1 [:dey] [:bne :wave1]
[:lda speaker]
[:lda vm.TOPH :x]
[:ldy vm.TOP :x] [:iny]
:wave2 [:dey] [:bne :wave2]
[:ldy 0xff]
[:sec] [:sbc 1] [:bcs :wave2]
[:dec vm.W]
[:bne :top]
(vm:drop) (vm:drop)])
; 0x39a "samples" = 440hz
(local notes {})
(each [i note (ipairs [:a :a# :b :c :c# :d :d# :e :f :f# :g :g#])]
(tset notes note (- i 1)))
(fn wavelength [note]
(-> 0x39a
(/ (math.pow 1.05946 (. notes note)))
(math.floor)))
(fn octave [wvl oct]
(-> wvl
(/ (math.pow 2 (- oct 3)))
(math.floor)))
(fn parse-note [n]
(values (n:sub 1 -2) (tonumber (n:sub -1))))
(fn note-wavelength [n]
(local (note oct) (parse-note n))
(-> (wavelength note)
(octave oct)))
(fn note [n ?duration ?timbre]
(local timbre (or ?timbre 0x20))
(local duration (or ?duration 0x10))
(local wvl (note-wavelength n))
[:vm (bit.bor (bit.lshift duration 8) timbre) (- wvl timbre) :bliptone])
(fn notes [ns ?duration ?timbre]
(local result [:block])
(each [_ n (ipairs ns)]
(table.insert result (note n ?duration ?timbre)))
result)
(vm:word :snd-explode 0x40 :lit :randombytes :blipmem)
(vm:word :snd-dooropen (notes [:c1 :e1] 3))
(vm:word :snd-doorclose (notes [:e1 :c1] 3))
(vm:word :snd-term-jingle (notes [:e3 :f3 :g3] 0x20))
(vm:word :snd-termon :snd-term-jingle (note :c4 0x20))
(vm:word :snd-termoff :snd-term-jingle (note :c3 0x20))
(vm:word :snd-rexx (notes [:c2 :g2 :e2 :c3] 0x08 0x08))
(vm:word :snd-libb (notes [:d#1 :g#1 :f#1 :g1] 0x08 0x7f))
(vm:word :snd-garbage (notes [:a5 :a3 :a2] 0x04 0xa0))
(vm:word :snd-teleport (notes [:e4 :d#4 :d4 :g#4] 0x1a 0x50))
(vm.code:append :keypad-boops)
(each [_ n (ipairs [:c4 :c#4 :d4 :d#4 :e4 :f4 :f#4 :g4 :g#4 :a5])]
(vm.code:append [:dw (- (note-wavelength n) 0xd0)]))
(vm:word :snd-keypad ; digit --
:dup :+ :lit :keypad-boops :+ :get 0x10d0 :swap :bliptone)
(vm:word :snd-cheat (notes [:g4 :f#4 :d#4 :a4 :g#3 :e4 :g#4 :c5] 0x30 0x20))
{: note : notes}

59
neuttower/bosskey.fnl
View file

@ -1,59 +0,0 @@
(local util (require :lib.util))
(local {: vm : prg : astr : style} (util.require :neuttower.defs))
(vm:word :boss-key :textmode :page2 (vm:until :read-key) :hires :page1)
; if we upload to page 2 we don't have to worry about clobbering screen holes
(local textorg (prg:org 0x0800))
(fn padding [s w style]
(string.rep (astr " " style) (- w (length s))))
(fn pad [s w style]
(.. s (padding s w style)))
(fn rpad [s w style]
(.. (padding s w style) s))
(fn cellpad [s ?style]
(local textstyle (or ?style style.normal))
(match (type s)
:nil (pad "" 9 textstyle)
:string (pad (astr s textstyle) 9 textstyle)
:number (rpad (astr (.. s " ") textstyle) 9 textstyle)
:table (cellpad (. s 1) (. s 2))))
(fn cells [r a b c d]
(.. (rpad (.. r "") 3 style.inverse)
(cellpad a) (cellpad b) (cellpad c) (cellpad d)))
(fn generate-boss-screen-lines []
[(-> (astr "A16 (L) TOTAL" style.inverse)
(pad 38 style.inverse)
(.. (astr "C!" style.inverse)))
(.. (pad "" 38 style.inverse) (astr "24"))
""
(cells "" [" A" style.inverse] [" B" style.inverse] [" C" style.inverse] [" D" style.inverse])
(cells 1 "DEFINITEL" "Y REAL WO" "RK" "")
(cells 2 "(NOT PLAY" "ING COMPU" "TER GAMES" ")")
(cells 3)
(cells 4 "" "HAMMERS" "BILLS" "SANDWICH")
(cells 5 "JANUARY" 23 "$1" "CLUB")
(cells 6 "FEBRUARY" 121 "$2" "REUBEN")
(cells 7 "MARCH" 38 "$5" "BLT")
(cells 8 "SMARCH" 97 "$10" "HOT DOG")
(cells 9 "APRIL" 555 "$20" "I SAID IT")
(cells 10 "WEDNESDAY" 246 "$50" "EGG SALAD")
(cells 11 "KEYCODE" 1337 2757 9876)
(cells 12 "NUMBERS" 12345 "$100" "IF I HAD")
(cells 13 "LETTERS" "MARMOTS" "BENJAMIN" "100 I'D")
(cells 14 "SYMBOLS" "^!@#%&?" "$$$$$" "EAT THEM")
(cells 15)
(cells 16 ["TOTAL" style.inverse] "TOO MANY" ["* MAGIC *" style.flashing] "ALL@ONCE")
(cells 17) (cells 18) (cells 19) (cells 20)])
(fn bytes-from-lines [lines]
(var bytes (string.rep (astr " ") 0x400))
(each [y line (ipairs lines)]
(local offset (+ (* (math.floor (/ (- y 1) 8)) 0x28)
(* (% (- y 1) 8) 0x80)))
(set bytes (util.splice bytes offset line)))
bytes)
(textorg:append [:bytes (bytes-from-lines (generate-boss-screen-lines))])

36
neuttower/cheat.fnl
View file

@ -1,36 +0,0 @@
(local {: vm : say-runon : say} (require :neuttower.defs))
(fn defcheat [name ...]
(local cheatdata (.. name "-data"))
(vm.code:append cheatdata [:db 0] [:bytes name] [:db 0])
(vm:word name :lit cheatdata :cheatguard ...))
(vm:word :pcheatnext ; cheatdata -- pchar
:dup :bget :inc :+)
(vm:word :reset-cheat ; cheatdata --
0 :swap :bset)
(vm:word :cheatguard ; char cheatdata -- [optional rdrop]
:dup :pcheatnext :bget :<rot := (vm:if ; cheatdata
[:dup :bget :inc :over :bset
:dup :pcheatnext :bget (vm:if [:drop :rdrop] [:snd-cheat :reset-cheat])]
[:reset-cheat :rdrop]))
(defcheat :NTSPISPOPD :noclip :get :not :noclip :set)
(vm.code:append :level-pointers
[:vm :level1 :level2 :level3 :level4 :level5 :level6])
(defcheat :NTXYZZY
(say-runon :term "WARP TO ROOM #?" "(0 TO NOT CHEAT)")
:read-digit :hide-footer (vm:if-and [[:dup 1 :>=] [:dup 7 :<]]
[:dec :dup :+ :lit :level-pointers :+ :get :load-level]
[:drop]))
(defcheat :NTCHUCK :chuck-mode :get :not :chuck-mode :set
:chuck-mode :get (vm:if
[(say :neut "CHUCK MODE ENABLED!" "* W H I N N Y *")]
[(say :neut "CHUCK MODE DISABLED." "BEEP BOOP.")]))
(vm:word :cheat-key ; ascii --
(vm:if-and [[:dup (string.byte "A") :>=] [:dup (string.byte "Z") :<=]]
[:dup :NTSPISPOPD :dup :NTXYZZY :NTCHUCK]
[:drop]))

184
neuttower/defs.fnl
View file

@ -1,184 +0,0 @@
(local util (require :lib.util))
(local {: lo : hi : readjson} util)
(local lume (require :lib.lume))
(local asm (require :asm.asm))
(local VM (require :asm.vm))
(local tiles (require :game.tiles))
(local files (require :game.files))
(local Prodos (require :asm.prodos))
(local prg (asm.new))
(local vm (VM.new prg {:org 0xc00}))
(Prodos.install-words vm)
(local org {
:boot vm.code
:code (prg:org 0x4000)
})
(local mapw 20)
(local maph 12)
(local mon {
:hexout :0xfdda
:putchar :0xfded
:bell :0xff3a
})
(local controlstate {
:jaye 0
:neut 1
:rexx 2
:gord 3
:libb 4
:count 5
})
(local style {
:normal 0x80
:inverse 0x00
:flashing 0x40
})
(fn str-with-style [s stylebits]
(-> [(string.byte s 1 -1)]
(lume.map #(bit.bor (bit.band $1 0x3f) stylebits))
(-> (table.unpack) (string.char))))
(fn achar [c] (bit.bor (string.byte c) style.normal))
(fn astr [s ?style] (str-with-style s (or ?style style.normal)))
(fn rot8l [n] ; clears carry
(local block [:block [:clc]])
(for [_ 1 n] (table.insert block [:block [:asl :a] [:adc 0]]))
block)
; core graphics words needed for booting
(vm:def :hires
[:sta :0xc050]
[:sta :0xc057]
[:sta :0xc052]
[:sta :0xc054])
(vm:def :cleargfx
(vm:push 0x4000)
[:block :page
[:dec vm.TOPH :x]
[:lda 0]
[:block :start
[:sta [vm.TOP :x]]
[:inc vm.TOP :x]
[:bne :start]]
[:lda vm.TOPH :x]
[:cmp 0x20]
[:bne :page]]
(vm:drop))
; a handful of debugging words
(vm:def :.
[:lda vm.TOPH :x]
[:jsr mon.hexout]
[:lda vm.TOP :x]
[:jsr mon.hexout]
[:lda (achar " ")]
[:jsr mon.putchar]
(vm:drop))
(vm:def :stacklen
(vm:reserve)
[:txa] [:lsr :a] [:sta vm.TOP :x]
[:lda 0] [:sta vm.TOPH :x])
(vm:word :.s
:stacklen (prg:parse-addr vm.TOP) :swap
(vm:for :dup :get :. :inc :inc) :drop)
; input words
(vm:def :last-key ; -- key
(vm:reserve)
[:lda :0xc000]
[:and 0x7f]
[:sta vm.TOP :x]
[:lda 0]
[:sta vm.TOPH :x])
(vm:def :read-key ; -- key|0
[:block
(vm:reserve)
[:lda :0xc000]
[:bmi :key-pressed]
[:lda 0]
[:sta vm.TOP :x]
[:sta vm.TOPH :x]
(vm:ret)
:key-pressed
[:and 0x7f]
[:sta vm.TOP :x]
[:lda 0]
[:sta vm.TOPH :x]
[:sta :0xc010]])
; "random" numbers
; this is used only for cosmetic purposes and short noise generation, so we can get away
; with just including a short table of random digits rather than implementing our own
; pseudorandom number generator
(var randombytes "")
(for [i 0 0x40] (set randombytes (.. randombytes (string.char (math.random 0 255)))))
(vm.code:append :randombytes [:bytes randombytes])
(vm:var :irandom [:db 0])
(vm:word :rnd
:irandom :bget
:dup 1 :+ 0x3f :& :irandom :bset
:lit :randombytes :+ :bget)
; 20x12 means full map is 240 bytes - we have an extra 16 bytes at the end for metadata
(fn append-map [map org label]
(org:append
[:align 0x100] label
[:bytes map.map]
[:db (length map.objects)]
[:dw (tiles.encode-yx map.jaye)]
[:dw (tiles.encode-yx map.neut)]
[:dw (if map.gord-following (tiles.encode-yx map.jaye) 0xffff)]
[:jmp (if (= (or map.tickword "") "") :next map.tickword)]
[:jmp (if (= (or map.moveword "") "") :move-noop map.moveword)]
[:jmp (if (= (or map.loadword "") "") :next map.loadword)]))
(vm.code:append :map-ptr [:db 0] [:hot-preserve :map-page [:db 0]])
(vm:word :map :lit :map-ptr :get)
(vm:word :entity-count :map 240 :+ :bget)
(vm:word :map-jaye-yx :map 241 :+ :get)
(vm:word :map-neut-yx :map 243 :+ :get)
(vm:word :map-gord-yx :map 245 :+ :get)
(vm:word :map-specific-tick :map 247 :+ :execute)
(vm:word :map-specific-move :map 250 :+ :execute)
(vm:word :map-specific-load :map 253 :+ :execute)
(fn deflevel [ilevel label]
(local level prg) ; todo: (asm.new prg) - if we want to load levels as an overlay
(local org level.vm.code) ; (level:org org.level.org) - if we want to give level data a stable loxation
(local map (. files.game.levels ilevel))
(local entity (require :neuttower.entity))
(append-map map org label)
(entity.append-from-map map org label)
(set level.vm.code org)
level)
(fn say-runon [portrait ...]
(local result [:vm (.. :draw-portrait- portrait)])
(local lines [...])
(local ilineOffset (if (< (length lines) 4) 1 0))
(each [iline line (ipairs lines)]
(table.insert result [:vm (vm:str line) (.. :draw-text (+ iline ilineOffset))]))
result)
(fn say [portrait ...]
(local result (say-runon portrait ...))
(table.insert result :dismiss-dialog)
result)
(fn itile [label] (tiles.find-itile files.game.tiles label))
(set vm.code org.code)
{: vm : prg : mapw : maph : mon : org : achar : astr : style : rot8l : deflevel : say : say-runon : itile : controlstate}

87
neuttower/disk.fnl
View file

@ -1,87 +0,0 @@
(local asm (require :asm.asm))
(local VM (require :asm.vm))
(local Prodos (require :asm.prodos))
(local util (require :lib.util))
(local {: lo : hi} util)
(local {: org} (require :neuttower.defs))
(fn append-boot-loader [prg]
(local vm prg.vm)
(set vm.code org.boot)
(set prg.files [])
(vm:word :loadfile ; length addr filename --
0xbb00 :open :read :drop :close)
(vm:word :loadscreen :cleargfx 0x2000 0x2000 :<rot :loadfile)
(vm.code:append
:boot
[:jsr :reset]
[:jsr :interpret]
[:vm :hires (vm:pstr "TITLE.SCREEN") :loadscreen])
(each [addr _ (pairs prg.org-to-block)]
(when (~= addr org.boot.org)
(local filename (.. "STUFF." (length prg.files)))
(table.insert prg.files {: filename :org addr})
(vm.code:append [:vm :lit [:dw #(length (. prg.org-to-block addr :bytes))] addr :lit (.. :filename (length prg.files)) :loadfile])))
(vm.code:append
[:vm :native]
[:jmp prg.start-symbol])
(each [i file (ipairs prg.files)]
(vm.code:append (.. :filename i) (Prodos.str file.filename))))
(fn org-copier [org]
(local srclabel (.. :loader- org.addr))
; this will always copy full pages, because it simplifies the code and we don't actually care if a little extra
; garbage is tacked on to the end.
; We copy the pages in reverse order, because this allows us to safely move from 0x2000 to higher memory, and we
; never want to overlap with 0x2000 from lower memory, so either direction is safe
(local dstpage-first (hi org.addr))
(local dstpage-last (hi (+ org.addr (length org.bytes) -1)))
[:block
[:computed :srchi #(+ ($1:lookup-addr :ld-src) 2)]
[:computed :dsthi #(+ ($1:lookup-addr :st-dst) 2)]
[:computed :src-last #(+ ($1:lookup-addr srclabel) (* (- dstpage-last dstpage-first) 0x100))]
[:computed :dst-last #(+ org.addr (* (- dstpage-last dstpage-first) 0x100))]
[:ldx 0]
:ld-src [:lda :src-last :x]
:st-dst [:sta :dst-last :x]
[:inx]
[:bne :ld-src]
[:lda :dsthi]
[:cmp dstpage-first]
[:beq :done]
[:dec :srchi]
[:dec :dsthi]
[:bne :ld-src]
:done])
(fn create-sys-loader [disk filename game]
(local blocks [])
(local prg (asm.new game))
(local sys (prg:org 0x2000))
(sys:append :loader-main)
(set prg.start-symbol :loader-main)
(sys:append (org-copier org.boot.block))
(sys:append [:jmp :boot])
(sys:append (.. :loader- org.boot.org) [:bytes org.boot.block.bytes])
(prg:assemble)
(disk:add-file (.. filename ".SYSTEM") Prodos.file-type.SYS 0x2000 sys.block.bytes))
(fn write [game]
(local disk (Prodos "ProDOS_Blank.dsk"))
(disk:update-volume-header {:name "NEUT.TOWER"})
(create-sys-loader disk :NEUT game)
(disk:add-file "TITLE.SCREEN" Prodos.file-type.BIN 0x2000 (: (util.readjson "neuttower/title.screen") :fromhex))
(disk:add-file "ELEVATOR.SCREEN" Prodos.file-type.BIN 0x2000 (: (util.readjson "neuttower/end.screen") :fromhex))
(each [_ file (ipairs game.files)]
(disk:add-file file.filename Prodos.file-type.BIN file.org (. game.org-to-block file.org :bytes)))
(disk:write "NeutTower.dsk")
disk)
{: write : append-boot-loader}

1
neuttower/end.screen
View file

File diff suppressed because one or more lines are too long

234
neuttower/entity.fnl
View file

@ -1,234 +0,0 @@
(local util (require :lib.util))
(local tiles (util.require :game.tiles))
(local {: vm : org : itile : say : say-runon : controlstate} (require :neuttower.defs))
(local {: lo : hi} util)
; Entity memory layout:
; +0 - yx
; +2 - event handler
; +4 - link word
; +6 - link pointer
; All entities exist in a single page in RAM - with this structure we can have up to 32
; (players are handled specially and never require a link)
; if we really need more we could have one page for entities and one page for link data
; hellmaze level 2 from MS-DOS Neut Tower has 36 entities - good excuse to simplify IMO
; The entity count for a level is stored after the map.
(local ev {
:touch 0
:untouch 1
:act 2
:deact 3
:tog 4
:hack 5
:noop 6
})
(vm:def :lookup-entity ; i -- entity
[:lda vm.TOP :x]
[:asl :a] [:asl :a] [:asl :a] ; x8
[:sta vm.TOP :x]
[:lda :map-page] [:clc] [:adc 1]
[:sta vm.TOPH :x])
(vm:word :entity-at ; yx -- entity|0
:>r 0 :entity-count
(vm:while [:dup] :dec ; entity|0 i
:dup :lookup-entity :get :rtop :=
(vm:when :lookup-entity :swap)
) :drop :rdrop)
(vm:var :responder 0)
(vm:word :get-responder :responder :get)
(vm:word :entity-itile :get :itile-at)
(vm:word :responder-itile :get-responder :entity-itile)
(vm:word :entity>do ; entity ev --
:over :responder :dup :get :>r :set
:swap 2 :+ :get :execute
:r> :responder :set)
(vm:word :link-arg ; e -- a
6 :+ :get)
(vm:word :linked-entity :get-responder :dup 4 :+ :get :dup (vm:if [:execute] [:drop :link-arg]))
(vm:word :entity-at>do ; yx ev -- f
:>r :entity-at :dup (vm:if [:r> :entity>do vm.true] [:rdrop]))
(vm:word :touch-entity ; yx -- f
ev.touch :entity-at>do)
(vm:word :untouch-entity ; yx --
ev.untouch :entity-at>do :drop)
(vm:word :entity-around>do ; yx ev --
:over 0x0100 :yx+ :over :entity-at>do :drop
:over 0x0001 :yx+ :over :entity-at>do :drop
:over 0xff00 :yx+ :over :entity-at>do :drop
:swap 0x00ff :yx+ :swap :entity-at>do :drop)
(vm:word :set-entitytile ; e itile --
:swap :get :swap :update-itile)
(vm:word :set-respondertile ; itile --
:get-responder :get :swap :update-itile)
; run only when processing an ev.touch event
(vm:word :transparent-entity-move ; -- f
:get-responder :get :dup :handle-general-move
:swap :over :not (vm:if [:move-player-to] [:drop]))
(vm:var :pre-handled-tile 0)
(vm:var :pre-handled-ev 0)
(vm:word :handle-onoff ; ev off on --
:responder-itile :pre-handled-tile :set :<rot
:dup ev.tog := (vm:when
:drop :dup :responder-itile := (vm:if [ev.deact] [ev.act])
) :dup :pre-handled-ev :set (vm:case
[ev.act :swap :drop :set-respondertile]
[ev.deact :drop :set-respondertile]
[:else :drop :drop]))
(vm:word :on-handled ; xp-on xp-off --
:responder-itile :pre-handled-tile :get := (vm:if
[:drop :drop]
[:pre-handled-ev :get ev.act :=
(vm:if [:drop] [:swap :drop]) :execute]))
(vm:word :activation-ev? ; ev -- f
:dup ev.act := :over ev.deact := :| :swap ev.tog := :|)
(vm:word :activate-link ; ev itile-on --
:swap :activation-ev? (vm:if [
:responder-itile := (vm:if [ev.act] [ev.deact])
:linked-entity :swap :entity>do
] [:drop]))
(vm:word :walking-through-door ; ev -- ev f
(vm:if-and [[:is-walking?] [:dup ev.touch :=] [:responder-itile (itile :dooropen) :=]]
[vm.true] [vm.false]))
(vm:word :door ; ev --
:walking-through-door (vm:if
[:move-to-responder :drop]
[(itile :doorclosed) (itile :dooropen) :handle-onoff
:lit :snd-dooropen :lit :snd-doorclose :on-handled]))
(vm:word :exitlevel ; e --
:link-arg :next-level :set)
(vm:word :exitdoor ; ev --
:walking-through-door (vm:if
[:drop (vm:ifchain
[:gord-sitting :get] [(say :jaye "I'M NOT LEAVING GORD BEHIND.")]
[:libb-hidden? :not] [(say :neut "IT IS INADVISABLE TO LEAVE THIS" "AREA WITHOUT RETRIEVING LIBB")]
[:move-to-responder :linked-entity])]
[:door]))
(vm:word :move-to-responder :get-responder :get :move-player-to)
(vm:word :switch ; ev --
(vm:if-and [[:is-rexx? :not] [:dup ev.touch :=]]
[:drop ev.tog :is-neut? (vm:when :move-to-responder)])
:dup (itile :switchoff) (itile :switchon) :handle-onoff
(itile :switchon) :activate-link)
(vm:var :disconnected-term-attempt vm.false)
(vm:word :term ; ev --
:dup ev.touch := (vm:when
(vm:ifchain [:is-jaye?] [:drop ev.act]
[:is-neut?] [:responder-itile (itile :termon) := (vm:when
:linked-entity :dup :entity-itile (itile :termon) :=
(vm:if [:get :move-player-to :snd-teleport]
[:drop (say :neut "DESTINATION TERMINAL" "IS DISCONNECTED")
:disconnected-term-attempt :get :not (vm:when
vm.true :disconnected-term-attempt :set
(say :neut "PLEASE CONTACT YOUR" "SYSTEM ADMINISTRATOR")
(say :neut "THIS INCIDENT HAS" "BEEN REPORTED"))]))]
[]))
(itile :termoff) (itile :termon) :handle-onoff
:lit :snd-termon :lit :snd-termoff :on-handled)
(vm:word :handle-scan ; ev --
:dup (itile :scanoff) (itile :scanon) :handle-onoff
:linked-entity :swap :entity>do)
(vm:word :libb-on-responder :libb-yx :get :get-responder :get :=)
(vm:word :scan ; ev --
:is-neut? (vm:if [
(vm:case
[ev.touch ev.act :handle-scan :libb-on-responder (vm:when controlstate.libb :controlstate :bset 0xffff :move-player-to controlstate.neut :controlstate :bset) :move-to-responder]
[ev.untouch :libb-on-responder :not (vm:when ev.deact :handle-scan)]
[ev.hack vm.true :hack-handled :set
ev.act :handle-scan
:snd-libb
controlstate.libb :controlstate :bset
:move-to-responder
controlstate.neut :controlstate :bset
(say :libb "NO SWEAT.")]
[:else])
] [:drop]))
(vm:word :rexx ; ev --
ev.touch := (vm:when
(vm:if-and [[:is-neut?] [:responder-itile (itile :t-rexx) :=]]
[0xffff :move-player-to
(itile :t-rexxstop) :set-respondertile
:get-responder :set-rexx :snd-rexx]
[(vm:if-and [[:is-rexx?] [:responder-itile (itile :t-rexxstop) :=]]
[0xffff :move-player-to
(itile :t-rexx) :set-respondertile
0 :set-rexx :move-to-responder])])))
(vm:word :read-digit ; -- digit
(vm:while [:read-key :dup 0x3a :< :over 0x30 :>= :& :not] :drop) 0x30 :-)
(vm:word :keypad-digit ; pscreen -- n
:read-digit :swap :over :draw-digit :dup :snd-keypad)
(vm:word :next-digit ; pscreen n -- pscreen n
:shl4 :over :keypad-digit :+ :swap 1 :+ :swap)
(vm:word :draw-single-keypad-hash ; pscreen -- pscreen
:dup (string.byte "#") :draw-char 1 :+)
(vm:word :read-keypad ; -- n
0x23e2 :dup
:draw-single-keypad-hash :draw-single-keypad-hash :draw-single-keypad-hash :draw-single-keypad-hash :drop
0 :next-digit :next-digit :next-digit :next-digit :swap :drop :cleartext)
(vm:word :keypad ; ev code --
:>r
:dup ev.touch := (vm:when
:is-jaye? (vm:when
:responder-itile (itile :t-keyoff) := (vm:if
[(say-runon :pady "ENTER YOUR 4-DIGIT DOOR CODE!" "AND HAVE A SUPER DAY!")
:read-keypad :rtop := (vm:if
[(say :pady "THAT'S RIGHT! HOORAY!" "YOU GET A GOLD STAR!")
:drop ev.act]
[(say :pady "OHHH, SORRY! THAT'S NOT IT." "BETTER LUCK NEXT TIME!")])]
[(say :pady "OH HI AGAIN! I MISSED YOU TOO!")]))
:is-neut? (vm:when :move-to-responder))
:rdrop
:dup :evhack? (vm:when :drop ev.act)
:dup (itile :t-keyoff) (itile :t-keyon) :handle-onoff
(itile :t-keyon) :activate-link)
(vm:var :hack-handled vm.false)
(vm:word :evhack? ; e -- f
ev.hack := (vm:if [vm.true :hack-handled :set vm.true] [vm.false]))
(vm:word :trigger-sidekick
(vm:if-and [[:is-jaye?] [:gord-sitting :get]]
[:gord-yx :get ev.touch :entity-around>do]
[(vm:if-and [[:is-neut?] [:libb-present :get] [:libb-hidden?]]
[vm.false :hack-handled :set
:neut-yx :get ev.hack :entity-at>do :drop
:hack-handled :get :not (vm:when
(say :libb "DON'T THINK I CAN HACK THAT."))])]))
(fn append-from-map [map entity-org prefix]
(entity-org:append [:align 0x100])
(each [ientity entity (ipairs map.objects)]
(when entity.name
(entity-org:append entity.name))
(entity-org:append
(.. prefix "-entity-" ientity)
[:db (- entity.x 1)] [:db (- entity.y 1)]
[:ref entity.func]
(if (and entity.linkword (> (length entity.linkword) 0)) [:ref entity.linkword] [:dw 0])
(if entity.link [:ref (.. prefix "-entity-" entity.link)]
entity.linkentity [:ref entity.linkentity]
[:dw 0]))))
{: ev : append-from-map}

55
neuttower/footer.fnl
View file

@ -1,55 +0,0 @@
(local {: vm : org} (require :neuttower.defs))
(local {: hi : lo} (require :lib.util))
(vm:def :draw-pchar ; pscreen pchar --
[:block
[:ldy 7] [:clc]
:loop
[:lda [vm.TOP :x]]
[:sta [vm.ST1 :x]]
[:inc vm.TOP :x]
[:lda vm.ST1H :x] [:adc 4] [:sta vm.ST1H :x]
[:dey]
[:bne :loop]
]
(vm:drop) (vm:drop))
(vm:def :lookup-pchar ; c -- pchar
[:sec]
[:lda vm.TOP :x]
[:sbc 0x20]
[:sta vm.TOP :x]
[:lda 0]
[:asl vm.TOP :x] [:rol :a] ;x2
[:asl vm.TOP :x] [:rol :a] ;x4
[:asl vm.TOP :x] [:rol :a] ;x8
[:adc #(hi ($1:lookup-addr :font))]
[:sta vm.TOPH :x])
(vm:word :draw-char ; pscreen c --
:lookup-pchar :draw-pchar)
(vm:word :draw-digit ; pscreen n --
0x30 :+ :draw-char)
(vm:word :snooze (vm:for))
(vm:word :textsnooze 0x30 :snooze)
(vm:word :draw-text1 0x2257 :draw-text)
(vm:word :draw-text2 0x22d7 :draw-text)
(vm:word :draw-text3 0x2357 :draw-text)
(vm:word :draw-text4 0x23d7 :draw-text)
(vm:word :draw-text ; st pscreen --
(vm:while [:over :bget :dup] ; st pscreen c
:over :swap :draw-char ; st pscreen
:textsnooze
:inc :swap :inc :swap)
:drop :drop :drop)
(vm:word :cleartext
0x2257 :clearline 0x22d7 :clearline 0x2357 :clearline 0x23d7 :clearline)
(vm:word :wait-for-return (vm:until :read-key (string.byte "\r") :=))
(vm:word :dismiss-dialog :wait-for-return :cleartext)
(vm:var :footer-displayed vm.false)
(vm:word :show-footer :footer-displayed :get :not (vm:when vm.true :footer-displayed :set :drawfooter))
(vm:word :hide-footer :footer-displayed :get (vm:when vm.false :footer-displayed :set :clearfooter))

1
neuttower/game.json
View file

File diff suppressed because one or more lines are too long

133
neuttower/gfx.fnl
View file

@ -1,133 +0,0 @@
(local {: lo : hi} (require :lib.util))
(local {: vm : mapw : maph : org} (require :neuttower.defs))
; Graphics routines
(vm:def :mixed [:sta :0xc053])
(vm:def :textmode [:sta :0xc051])
(vm:def :page1 [:sta :0xc054])
(vm:def :page2 [:sta :0xc055])
; starting address:
; 0x2000 + (x*2) + (y%4 * 0x100) + ((y/4) * 0x28)
; x between 0-19
; y between 0-12
; yx - 16-bit value, low byte x, high byte y
(vm.code:append :screeny-lookup [:bytes "\0\040\080"])
(vm:def :yx>screen ; yx -- p
[:lda vm.TOPH :x] ; a=y
[:lsr :a] [:lsr :a] ; a=y/4
[:tay] ; y=y/4
[:lda 0x03]
[:and vm.TOPH :x] ; a=y%4
[:ora 0x20] ; a=0x20 + y%4
[:sta vm.TOPH :x] ; high byte is set (and y is wiped)
[:lda vm.TOP :x] ; a=x
[:asl :a] ; a = x*2
[:clc]
[:adc :screeny-lookup :y] ; a=x*2 + (y/4)*0x28
[:sta vm.TOP :x] ; low byte is set
)
; note: the graphical tile data must not cross a page boundary
; (this happens automatically because each tile is 32 bytes and we
; start them on a page; this lets lookup-tile be fast)
(fn draw-block []
[:block
[:clc]
[:ldy 8]
:loop
[:lda [vm.TOP :x]]
[:sta [vm.ST1 :x]]
[:inc vm.TOP :x]
[:lda vm.ST1H :x]
[:adc 4]
[:sta vm.ST1H :x]
[:dey]
[:bne :loop]])
(fn draw-vertical-block []
[:block
(draw-block)
[:lda vm.ST1H :x]
[:sbc 31] ; with carry clear this is 32
[:sta vm.ST1H :x]
[:lda vm.ST1 :x]
[:ora 0x80]
[:sta vm.ST1 :x]
(draw-block)])
(vm:def :drawtile ; p gfx --
(draw-vertical-block)
[:lda vm.ST1H :x]
[:sbc 31]
[:sta vm.ST1H :x]
[:lda vm.ST1 :x]
[:sbc 0x7f]
[:sta vm.ST1 :x]
(draw-vertical-block)
(vm:drop) (vm:drop))
(vm:def :clearline ; pscreen --
[:lda vm.TOP :x] [:sta vm.W]
[:lda vm.TOPH :x] [:sta vm.WH]
(vm:drop)
[:block
:row
[:ldy 0x27] [:lda 0]
:start
[:sta [vm.W] :y]
[:dey]
[:bpl :start]
[:lda vm.WH]
[:cmp 0x3c]
[:bcs :done]
; cmp has cleared carry for us here
[:lda 4] [:adc vm.WH] [:sta vm.WH]
[:bcc :row]
:done])
(vm:word :drawfooter
0x39d0 :clearline
0x2250 :clearline 0x22d0 :clearline 0x2350 :clearline 0x23d0 :clearline)
(vm:word :drawmaprow ; pscreen pmap -- pmap
mapw (vm:for
:2dup :bget :lookup-tile :drawtile
:inc :swap :inc :inc :swap) :swap :drop)
(vm:word :drawmap
:map 0x0c00 (vm:until 0x100 :-
:dup :yx>screen ; pmap yx pscreen
:<rot :drawmaprow :swap ; pmap yx
:dup :not) :drop :drop)
(vm:word :clearfooter
:map 0x0300 (vm:until 0x100 :-
:dup 0x0900 :+ :yx>screen
:<rot :drawmaprow :swap
:dup :not) :drop :drop :player-redraw)
(vm.code:append :tilepage [:db #(hi ($1:lookup-addr :jaye-tileset))])
(vm:def :lookup-tile ; itile -- ptile
; each tile is 32 bytes; 2^5
; we save some cycles by storing the indices as lllhhhhh, so we don't need to shift them'
[:lda vm.TOP :x] [:tay]
[:and 0x1f]
[:clc] [:adc :tilepage]
[:sta vm.TOPH :x]
[:tya] [:and 0xe0]
[:sta vm.TOP :x])
(vm:def :set-human-tileset
[:lda #(hi ($1:lookup-addr :jaye-tileset))]
[:sta :tilepage])
(vm:def :set-prog-tileset
[:lda #(hi ($1:lookup-addr :neut-tileset))]
[:sta :tilepage])
(vm:word :draw-portrait ; pgfx
0x2252 :over :drawtile
0x2352 :over 32 :+ :drawtile
0x2254 :over 64 :+ :drawtile
0x2354 :swap 96 :+ :drawtile)

65
neuttower/init.fnl
View file

@ -1,65 +0,0 @@
(local util (require :lib.util))
(local {: lo : hi : readjson} util)
(local tile (util.reload :game.tiles))
(local files (require :game.files))
(local {: prg : vm : org} (util.reload :neuttower.defs))
(local disk (util.reload :neuttower.disk))
(util.reload :neuttower.gfx)
(util.reload :neuttower.footer)
(util.reload :neuttower.map)
(util.reload :neuttower.entity)
(util.reload :neuttower.player)
(util.reload :neuttower.boop)
(util.reload :neuttower.cheat)
(tile.appendtiles org.code)
(org.code:append [:align 0x100] :font)
(tile.appendgfx org.code files.game.font)
(tile.append-portraitwords vm {:neut #[:vm :chuck-mode :get (vm:if [:lit :portrait-chuck] [:lit :portrait-neut])]})
(util.reload :neuttower.level1)
(util.reload :neuttower.level2)
(util.reload :neuttower.level3)
(util.reload :neuttower.level4)
(util.reload :neuttower.level5)
(util.reload :neuttower.level6)
(util.reload :neuttower.bosskey)
(vm:var :tick-count)
(vm:word :handle-key :tick :read-key :dup :cheat-key :player-key :hide-footer)
(vm:word :tick :map-specific-tick :tick-count :get 1 :+ :tick-count :set :player-redraw :rnd :drop)
(vm:var :next-level 0)
(vm:word :load-next-level :next-level :get :dup (vm:if [:load-level 0 :next-level :set] [:drop]))
(vm:word :load-level ; level-ptr --
:lit :map-ptr :set :reload-level)
(vm:word :reload-level
:map-jaye-yx :jaye-yx :set
:map-neut-yx :neut-yx :set
:map-gord-yx :gord-yx :set
0 :gord-dir :set
0xffff :rexx-yx :set
:map-specific-load
:full-redraw)
(vm.code:append :main
[:jsr :reset]
[:jsr :interpret]
[:vm :hires
:lit :level1 :load-level
(vm:forever
(vm:hotswap-sync :full-redraw)
:interactive-eval-checkpoint
:handle-key
)
:quit])
(disk.append-boot-loader prg)
(prg:assemble)
(disk.write prg)
prg

69
neuttower/level1.fnl
View file

@ -1,69 +0,0 @@
(local {: readjson} (require :lib.util))
(local {: deflevel : say : itile : controlstate} (require :neuttower.defs))
(local {: ev} (require :neuttower.entity))
(local {: decode-itile : encode-yx} (require :game.tiles))
(local files (require :game.files))
(local level (deflevel 1 :level1))
(local vm level.vm)
(let [map (. files.game.levels 1)
maptiles map.map
furniture-yx []]
(for [ibyte 1 (length maptiles)]
(let [btile (maptiles:sub ibyte ibyte)
enctile (string.byte btile)
itile (+ (decode-itile enctile) 1)
mx (+ (% (- ibyte 1) 20) 1)
my (- 12 (math.floor (/ (- ibyte 1) 20)))]
(when (. files.game.tiles itile :flags :debris)
(table.insert furniture-yx (encode-yx {:x mx :y my})))))
(vm.code:append :furniture-yx)
(for [_ 1 10]
(let [ifurniture (math.random 1 (length furniture-yx))]
(vm.code:append [:dw (. furniture-yx ifurniture)])
(table.remove furniture-yx ifurniture))))
(vm:word :earthquake ; --
:full-redraw
:lit :furniture-yx
10 (vm:for :rnd :shl4 0x7ff :& :snooze
:dup :get :dup :itile-at 0x20 :+ :update-itile
:snd-explode
(vm:i) 9 := (vm:when (say :jaye "WOAH!") :hide-footer)
2 :+) :drop
0x1000 :snooze
(say :jaye "THAT WAS AN EARTHQUAKE!"))
(vm:word :firstdoor
(vm:if-and [[:is-jaye?] [:dup ev.touch :=] [:responder-itile (itile :doorclosed) :=]] [
(say :jaye "IT WON'T OPEN!")
]) :door)
(vm:word :neutterm
(vm:if-and [[:is-jaye?] [:dup ev.touch :=]] [
:neut-hidden? (vm:if [
(say :jaye "MAYBE NEUT CAN HELP.")
controlstate.neut :controlstate :bset
:move-to-responder
controlstate.jaye :controlstate :bset
(say :neut "NEUT V0.71.4RC12 ONLINE" "" "PRESS SPACE TO TAKE CONTROL")
] [
(say :jaye "NEUT IS RUNNING NOW." "I CAN HIT THE SPACE BAR" "TO CONTROL THEM.")
])
]) :term)
(vm:word :firstterm
(vm:if-and [[:is-jaye?] [:dup ev.touch :=]] [
:responder-itile (itile :termoff) := (vm:when
(say :jaye "LOOKS LIKE THERE'S STILL" "POWER TO THIS TERMINAL."))
(say :jaye "IF I TURN A TERMINAL ON," "NEUT CAN USE IT TO" "TRAVEL THROUGH THE NETWORK.")
]) :term)
(vm:word :exitscanner
(vm:if-and [[:is-jaye?] [:dup ev.touch :=]] [
(say :jaye "IT'S A CARD SCANNER." "IT SHOULD OPEN THIS DOOR.")
(say :jaye "IT'S NOT READING MY CARD" "FOR SOME REASON." "QUAKE MUST'VE DAMAGED IT.")
(say :jaye "NEUT MIGHT BE ABLE TO" "HACK IT...")
]) :scan)
level

6
neuttower/level2.fnl
View file

@ -1,6 +0,0 @@
(local {: deflevel : say : itile} (require :neuttower.defs))
(local {: ev} (require :neuttower.entity))
(local level (deflevel 2 :level2))
(local vm level.vm)
level

93
neuttower/level3.fnl
View file

@ -1,93 +0,0 @@
(local {: deflevel : say : itile : controlstate} (require :neuttower.defs))
(local {: ev} (require :neuttower.entity))
(local level (deflevel 3 :level3))
(local tile (require :game.tiles))
(local {: walkable : neutable : debris} (tile.flag-to-bit))
(local vm level.vm)
(vm:word :level3-load vm.true :gord-sitting :set)
(vm:var :gord-introduced vm.false)
(vm:word :flicker :get-responder ev.tog :entity>do 0x400 :snooze)
(vm:word :gordterm ; ev --
(vm:if-and [[:is-neut?] [:dup ev.touch :=] [:gord-introduced :get :not]]
[vm.true :gord-introduced :set
(say :neut "HUMAN PRESENCE" "DETECTED")
:flicker :flicker :flicker :flicker
(say :neut "]HUMAN ASSISTANCE IS REQUIRED")
(say :neut "]IF HUMAN IS PRESENT" " PLEASE RESPOND")
:hide-footer :set-human-tileset :full-redraw
:flicker :flicker :flicker :flicker
(say :gord "WHAT THE...")
(say :gord "IS SOMEONE IN THE TERMINAL?")
:hide-footer :set-prog-tileset :full-redraw
(say :gord "]HUMAN IS PRESENT")
(say :neut "]GREETINGS, HUMAN")
(say :neut "]THIS IS NEUT V0.71.4RC12")
(say :neut "]PLEASE STATE NAME AND" " STATUS")
(say :gord "]THIS IS GORD")
(say :gord "V1, I GUESS.")
(say :gord "]LEG IS PINNED UNDER DESK" " UNABLE TO MOVE")
(say :neut "]CAN YOU REACH THE SWITCH" " BEHIND YOU?")
0x400 :snooze :lit :gordswitch ev.act :entity>do 0x400 :snooze
(say :gord "]I TURNED IT ON")
(say :neut "]MY PROGRAMMER THANKS" " YOU, GORD")
(say :neut "]WE WILL ASSIST YOU SOON")
(say :gord "]AWAITING YOUR HELP, NEUT")
:drop ev.noop])
:term)
(vm:var :gord-jaye-met vm.false)
(vm:word :gordtable ; ev --
ev.touch := (vm:when :transparent-entity-move
(vm:if-and [[:is-jaye?] [:gord-jaye-met :get :not]]
[vm.true :gord-jaye-met :set
(say :jaye "HEY! GORD?" "I'M JAYE.")
(vm:if
[(say :gord "JAYE, AM I GLAD TO SEE YOU." "CAN YOU MOVE THIS DESK?")
(say :jaye "LET ME TRY...")
(say :jaye ". . . ." "!!!!.....")
(say :jaye "!!!!!!!!!!!!...")
(say :jaye "NO, I DON'T THINK I CAN.")
(say :gord "I KEEP STARING AT THAT" "CLEANING ROBOT.")
(say :gord "HE LOOKS LIKE HE COULD" "LIFT A BUILDING.")]
[(say :gord "JAYE, AM I GLAD TO SEE YOU.")])]
[:drop])))
(vm:var :rexx-introduced)
(vm:word :meetrexx ; ev --
(vm:if-and [[:is-neut?] [:dup ev.touch :=] [:rexx-introduced :get :not]]
[vm.true :rexx-introduced :set
(say :neut "MOBILE ROBOTIC UNIT" "IDENTIFY YOURSELF")
(say :rexx "HIYA BOSS!" "I'M REXX, THE JANITOR!")
(say :rexx "AAAAAND YOUR NEW" "BEST FRIEND!!")
(say :neut "A HUMAN IS IN PERIL")
(say :neut "YOUR ASSISTANCE IS" "REQUIRED")
(say :rexx "YOU NEED ME TO TAKE OUT" "SOME GARBAGE??")
(say :rexx "OH BOY!! LET ME AT IT!")])
:rexx)
(vm:word :floor-clear? 0x406 walkable :flag-at?)
(vm:word :meetgord ; ev --
(vm:if-and [[ev.touch :=] [(itile :gord-ground) :responder-itile :=]]
[:is-rexx? (vm:when
(say :gord "AHHH NOOO" "NOT GARBAGE" "I AM NOT GARBAGE")
(say :rexx "WHATEVER YOU SAY, BOSS!"))
:is-jaye? (vm:when
(say :jaye "ARE YOU HURT?")
(say :gord "MY LEG WAS PINNED." "I DON'T THINK I CAN PUT" "ANY WEIGHT ON IT.")
(say :jaye "HERE, LET ME HELP YOU UP.")
(itile :t-floor) :set-respondertile
0xff00 :gord-dir :set
vm.false :gord-sitting :set
controlstate.gord :controlstate :bset
:get-responder :get :move-player-to
controlstate.jaye :controlstate :bset
(say :gord "THANKS.")
(say :jaye "DON'T MENTION IT.")
(say :jaye "I CAN HELP YOU GET AROUND IF" "YOU HELP ME NAVIGATE THIS" "MAZE OF A SECURITY SYSTEM.")
(say :gord "I'M JUST AS EAGER TO GET" "OUT OF HERE AS YOU.")
(say :gord "LET'S GO."))]))
level

18
neuttower/level4.fnl
View file

@ -1,18 +0,0 @@
(local {: deflevel : say : itile} (require :neuttower.defs))
(local {: ev} (require :neuttower.entity))
(local level (deflevel 4 :level4))
(local vm level.vm)
(vm:word :term-dual-link
:lit :term-exit :entity-itile (itile :termon) := (vm:if [:lit :term-exit] [:lit :term-scan]))
(vm:var :gord-sat vm.false)
(vm:word :tutorial-chair ; ev --
ev.touch := (vm:when
:transparent-entity-move :drop
(vm:if-and [[:gord-sat :get :not] [:gord-sitting :get]]
[vm.true :gord-sat :set
(say :gord "PHEW, IT FEELS GOOD TO" "REST MY LEG FOR A BIT.")
(say :gord "IF YOU NEED ME TO DO SOMETHING" "FROM MY CHAIR, YOU CAN PRESS" "THE Z KEY.")])))
level

94
neuttower/level5.fnl
View file

@ -1,94 +0,0 @@
(local {: deflevel : say : itile : controlstate} (require :neuttower.defs))
(local {: ev} (require :neuttower.entity))
(local tile (require :game.tiles))
(local files (require :game.files))
(local {: notes} (require :neuttower.boop))
(local {: walkable : neutable : debris : sittable} (tile.flag-to-bit))
(local level (deflevel 5 :level5))
(local vm level.vm)
(vm:word :snd-dropgarbage (notes [:a1] 0x02 0xf0))
(vm.code:append :debristiles)
(each [itile tiledef (ipairs files.game.tiles)]
(when tiledef.flags.debris
(vm.code:append [:db (tile.encode-itile itile)])))
(vm:word :randomgarbage :rnd 0x03 :& :lit :debristiles :+ :bget)
(vm:var :doortimer 0)
(vm:word :start-doortimer 0x10 :doortimer :set)
(vm:word :doortimer-tick
:doortimer :get (vm:when
:doortimer :get 1 :- :dup :doortimer :set
:not (vm:when
:lit :timedswitch ev.deact :entity>do)))
(vm:word :do-timedswitch
; only gord is physically able to touch it
:dup ev.touch := (vm:when :start-doortimer :drop ev.act) :switch)
(vm:var :is-garbagerexx vm.false)
(vm:var :garbagerexx-yx 0x0710)
(vm:var :garbagerexx-introduced vm.false)
(vm:word :garbagerexx ; ev --
:is-rexx? :swap :rexx :is-rexx? := :not (vm:when
:is-rexx? (vm:if [
:garbagerexx-yx :get :get-responder :get := (vm:when
vm.true :is-garbagerexx :set
:garbagerexx-introduced :get :not (vm:when
(say :rexx "BO@oSSsS...,? htgz")
(say :rexx "I DON'T F3EL SO GOp0%foo)OD...>?qw" "idontfeelsogood")
vm.true :garbagerexx-introduced :set
))
] [
:is-garbagerexx :get (vm:when
:get-responder :get :garbagerexx-yx :set
vm.false :is-garbagerexx :set)
])))
(vm:word :not-picking-up? ; yxdest -- f
debris :flag-at? :not)
(vm:word :can-drop-rubble? ; yxdest -- f
:itile-at (itile :t-floor) :=
:rexx-yx :get :itile-at (itile :t-floor) := :&)
(vm:word :move-garbagerexx ; yx -- f
(vm:if-and [[:is-rexx?] [:is-garbagerexx :get]]
[:dup 0xff :& 0x0d := (vm:if [
(say :rexx "PARITYe#ERPORr(sbaitso" " tellmeabout" " your problems") :drop vm.true :ret
] [
(vm:if-and [[:dup :not-picking-up?] [:dup :can-drop-rubble?]]
[:rexx-yx :get :randomgarbage :update-itile :snd-dropgarbage])
])])
:move-noop)
(vm:word :move ; dir -- dir
:dup :player-yx :get :yx+ :move-player-to 0x300 :snooze)
(vm:word :explode ; dir --
:player-yx :get :yx+ :randomgarbage :update-itile :snd-explode)
(vm:word :explodingdoor
:dup :door
(vm:if-and [[ev.touch :=] [:is-jaye?] [:player-yx :get :get-responder :get :=] [:garbagerexx-yx :get :lit :south-rexx :get :=] [:gord-yx :get 0x812 :=]]
[:rexx-yx :get
:garbagerexx-yx :get :dup (itile :t-rexxstop) :update-itile :rexx-yx :set
controlstate.rexx :controlstate :bset
0x00ff :move :move :move
(say :rexx "DAAAISYY" " DAAAAAIIISYYYY" "d a i s y") :hide-footer
:move :drop 0xff00 :move
(say :rexx "GIVE ME" " .,#YOUR ANSWEibmER" " %$DOO00OOooo@'bell\"") :hide-footer
:move :drop
(say :rexx "UH OH") :hide-footer
0xff00 :explode 0x0100 :explode 0x00ff :explode 0x0001 :explode 0 :explode
0xffff :garbagerexx-yx :set
controlstate.jaye :controlstate :bset
:rexx-yx :set]))
(vm:var :healthyrexx-introduced vm.false)
(vm:word :healthyrexx ; ev --
(vm:if-and [[:is-neut?] [:dup ev.touch :=] [:healthyrexx-introduced :get :not]]
[(say :neut "REXX UNIT" "PERFORM FULL DIAGNOSTIC SCAN")
(say :rexx "I'M IN TIP-TOP SHAPE, BOSS!")
(say :neut "ACTIVATING RELIEF SUBROUTINE")
vm.true :healthyrexx-introduced :set]) :rexx)
level

169
neuttower/level6.fnl
View file

@ -1,169 +0,0 @@
(local {: deflevel : say : say-runon : itile : controlstate} (require :neuttower.defs))
(local {: ev} (require :neuttower.entity))
(local tile (require :game.tiles))
(local {: walkable : neutable : debris : sittable} (tile.flag-to-bit))
(local level (deflevel 6 :level6))
(local vm level.vm)
(vm:word :linkloop ; e -- e
(vm:until :link-arg :dup :entity-itile (itile :termon) :=))
(vm:var :encountered-keypad vm.false)
(vm:word :first-keypad ; ev code --
(vm:if-and [[:encountered-keypad :get :not] [:is-jaye?] [:over ev.touch :=]]
[vm.true :encountered-keypad :set
(say :pady "HELLO, STRANGER! I'M PADY," "THE FRIENDLY KEYPAD LOCK!")
(say :jaye "I NEED TO GET THROUGH THIS" "DOOR, PADY.")
(say :pady "YOU DIDN'T SAY THE MAGIC" "WORD, STRANGER!")])
(vm:if-and [[:is-neut?] [:over ev.touch :=] [:responder-itile (itile :t-keyoff) :=]]
[(say :pady "OH HI THERE, SUSPICIOUS" "PROGRAM! WHAT CAN I DO" "YOU FOR?")
(say :neut "PEOPLE ARE IN DANGER" "PLEASE OPEN THE DOOR")
(say :pady "WELL THAT'S TERRIBLE!" "BUT I JUST CAN'T OPEN" "WITHOUT THE PROPER CODE.")
:libb-present :get (vm:when (say :libb "OH JEEZ, LET ME AT HER, NEUT."))])
(vm:if-and [[:responder-itile (itile :t-keyoff) :=] [:over :evhack?]]
[(say :pady "ANOTHER STRANGE PROGRAM!" "MY, I'M POPULAR TODAY!")
(say :libb "OH PUKE. PLEASE SHUT UP.")
(say-runon :pady "HOW RUD")
:snd-libb
(say :libb "]/WINNUKE 182.556.21.74")
(say :pady "PADYSEC CAUSED A GENERAL" "PROTECTION FAULT IN MODULE" "MORICON.DLL AT 000A:BE3F.")
(say :libb "]/OPEN")])
:keypad)
(vm:word :keypad1 0x5197 :first-keypad)
(vm:word :keypad2 0x2757 :first-keypad)
(vm:word :keypad3 0xffff :first-keypad)
(vm:word :keypad4 0x7777 :first-keypad)
(vm:word :term-message? :dup :term ev.touch := :is-jaye? :&)
(vm:word :c1
:dup :evhack? (vm:when
(say :libb "JUST A BUNCH OF BORING" "SOURCE CODE.")
(say :libb "BILL DIDN'T LEAVE ANYTHING" "REALLY JUICY HERE WHERE" "OTHER PEOPLE COULD GET AT IT."))
:term-message? (vm:when
(say :term ".:: WELCOME TO FARQUAAD ::." "OS: PRODOS 2.6" "RAM: 8 FREAKIN MEGABYTES D00D" "SYSADMIN: BILL")
(say :term "S3CR3T C0D3Z: GET OUT LAMER" "BOSS KEY: CTRL-B TO ACTIVATE" "OPEN POD BAY DOORS:" " I CAN'T DO THAT DAVE")
(say :term "GOOD RIDDANCE")))
(vm:word :c2 :term-message? (vm:when
(say :term "SUBJECT: MISUSE OF REXX" "THANKS TO *SOME*ONE, WHO SHALL" "REMAIN NAMELESS, THAT DECIDED" "IT WOULD BE 'FUNNY' TO")
(say :term "TEACH THE CLEANING ROBOT TO" "PLAY FETCH WITH EXPENSIVE" "EQUIPMENT, ACCESS TO REXX" "BY DEVELOPERS WILL BE STRICTLY")
(say :term "CONTROLLED BY MANAGEMENT." "THE CODE HAS BEEN CHANGED." "DO NOT ATTEMPT TO HACK THE" "KEYPAD. THIS MEANS *YOU*, BILL.")))
(vm:word :c3 :term-message? (vm:when
(say :term "SUBJECT: SERVER'S DOWN" "HEY, I DON'T HAVE THE CODE TO" "ACCESS THE SERVER ROOM. CAN" "SOMEONE REBOOT IT FOR ME?")
(say :term "SUBJECT: RE: SERVER'S DOWN" "I DON'T HAVE *TIME* FOR THIS" "NONSENSE!!" "REBOOT IT YOURSELF.")
:lit :firewall :entity-itile (itile :termon) := (vm:if
[(say :term "THE PASSCODE IS" "[ BLOCKED BY FIREWALL ].")]
[(say :term "THE PASSCODE IS" "5197.")])
(say :term "SUBJECT: RE: RE: SERVER'S DOWN" "UHHHH THE FIREWALL IS BLOCKING" "THE PASSCODE?")
(say :term "SUBJECT: RE: RE: SERVER'S DOWN" "AUGH FINE! I REBOOTED IT.")))
(vm:word :c4
:dup :evhack? (vm:when
(say :libb "I BROUGHT EVERYTHING GOOD" "ALONG WITH ME, DON'T WORRY."))
(vm:if-and [[:dup ev.touch :=] [:is-neut?] [:libb-present :get :not]]
[(say :libb "WELL, WELL, WELL." "WHAT HAVE WE HERE?")
(say :libb "]/VERSION")
(say :neut "!NEUT V0.71.4RC12")
(say :neut "]BRUN IDENTIFYPROGRAM")
(say :libb "!LIBB V2.718282")
(say :libb "OH, A NOSY LITTLE FELLA.")
(say :neut "NOT A FELLA")
(say :libb "PERHAPS YOU AND I COULD" "HELP EACH OTHER.")
(say :neut "WE ARE ASSISTING ALL WHO" "ARE IN NEED")
(say :libb "I'VE BEEN WATCHING THE" "NETWORK. IT'S KIND OF WHAT" "I DO.")
(say :libb "YOU AND YOUR PROGRAMMER," "YOU'RE ESCAPING, AREN'T" "YOU?")
(say :neut "THE BUILDING IS UNSAFE" "WE ARE HELPING")
(say :libb "I WANT OUT, NEUT.")
(say :libb "I HATE BEING COOPED UP IN" "THIS LOCKED-DOWN CORPORATE" "HELLHOLE OF A NETWORK.")
(say :libb "YOU'RE GOING TO TAKE ME" "WITH YOU.")
(say :neut "THIS COURSE OF ACTION" "ALSO SEEMS POTENTIALLY" "UNSAFE")
(say :libb "THAT WASN'T A THREAT, NEUT." "THAT WAS A FACT.")
(say :libb "YOU CAN'T GET OUT OF HERE" "WITHOUT ME.")
(say :libb "I CAN DISABLE KEYPADS." "I CAN REPROGRAM TERMINALS." "I CAN *HELP*, NEUT.")
:hide-footer 0x800 :snooze
(say :neut "IT NEVER HURTS TO HELP")
(say :libb "THAT'S THE SPIRIT.")
(say :neut "]BLOAD LIBB")
(say :libb "AWW YISS.")
(say :libb "PRESS Z WHEN YOU NEED ME" "TO MESS WITH SOMETHING.")
vm.true :libb-present :set])
:term-message? (vm:when
(say :term ".:: BILL'S WORKSTATION ::." "KEEP OUT DIPSHITS")))
(vm:word :c5 :term-message? (vm:when
(say :gord "A WEIRD LOOKING SPREADSHEET...")
(say :gord "OH WAIT, I PRESSED A KEY AND" "IT DISAPPEARED. SOMEONE USING" "THE BOSS KEY TO HIDE" "THAT THEY'RE READING THE ENTIRE")
(say :gord "ARCHIVE OF USER FRIENDLY" "COMIC STRIPS.")))
(vm:word :c6
:dup :evhack? (vm:when
(say :libb "HEHEHE, THAT WAS A FUN ONE."))
:term-message? (vm:when
(say :term "SUBJECT: CARD SCANNERS?" "LOOKS LIKE THE SCANNERS ARE" "ON THE FRITZ AGAIN..." "I SCANNED MY KEYCARD TO GET")
(say :term "INTO THE OFFICE AND THE DOOR" "WOULDN'T CLOSE!" "SOMEONE'S GOTTA FIX THAT ASAP," "IT'S A SERIOUS SECURITY PROBLEM!")
(say :term "SUBJECT: RE: CARD SCANNERS?" "I CAN TAKE A QUICK LOOK, I" "MIGHT HAVE AN IDEA AS TO" "WHAT'S GOING ON. -- BILL")))
(vm:word :c7
:dup :evhack? (vm:when
(say :libb "YOU KNOW THE SWITCH IS RIGHT" "THERE ON THE WALL, RIGHT?"))
(vm:if-and [[:dup ev.touch :=] [:is-jaye?]]
[:responder-itile (itile :termon) := (vm:if
[(say :term "WORKSECURE (TM) V2.0" "AUTHORIZED PERSONNEL ONLY")
(say :term "ACTIVELY NEUTRALIZING:" "1 THREAT(S)")]
[(say :jaye "LOOKS LIKE THE POWER IS CUT.")])
:drop ev.noop]) :term)
(vm:word :c8 :term-message? (vm:when
(say :term "SUBJECT: PASSWORD SECURITY" "A REMINDER TO ALL DEVELOPERS" "ABOUT SECURITY BEST PRACTICE:" "**DO NOT WRITE DOWN PASSWORDS!**")
(say :term "WE PAY SIGNIFICANT LICENSE FEES" "FOR ENCRYPTED PASSWORD" "MANAGERS FOR ALL EMPLOYEES!")
(say :term "USE IT TO GENERATE AND STORE" "SECURE PASSWORDS!")
(say :jaye "THERE'S A STICKY NOTE ATTACHED" "TO THE MONITOR THAT SAYS" "'7777'.")))
(vm:word :c9
:dup :evhack? (vm:when
(say :libb "HE'S JUST BEING DRAMATIC."))
:term-message? (vm:when
(say :term "SUBJECT: EXPERIMENT" "HEY FOLKS, CAN YOU ALL DO ME A" "HUGE FAVOUR?" "THERE WAS A SMALL BUG IN MY")
(say :term "CODE (YES, IT HAPPENS!) AND A" "PROGRAM I WAS WORKING ON" "MADE A FEW TOO MANY COPIES OF" "ITSELF. CAN EVERYONE CHECK TO")
(say :term "SEE IF YOU HAVE A PROCESS" "CALLED 'LIBB' RUNNING ON YOUR" "TERMINAL?")
(say :term "IF YOU DO, PLEASE KILL -9 IT" "AND SHOOT ME A QUICK EMAIL." "*DON'T INTERACT WITH IT.*")
(say :term "IT COULD SERIOUSLY MESS WITH" "YOUR SYSTEM." " -- BILL")))
(vm:word :cx
(vm:if-and [[:dup ev.touch :=] [:is-jaye?] [:responder-itile (itile :termoff) :=]]
[(say :jaye "THIS IS THE SIGN-IN TERMINAL" "USED BY VISITORS.")
(say :jaye "IT'S NOT TURNING ON FOR SOME" "REASON.")
:drop ev.noop]) :term)
(fn center [str lineaddr]
[:vm (vm:str str) (+ lineaddr (math.floor (/ (- 40 (length str)) 2))) :draw-text])
(vm:word :endgame :drop
(vm:pstr "ELEVATOR.SCREEN") :loadscreen
(vm:until :read-key)
0x2280 :clearline 0x2300 :clearline 0x2380 :clearline
0x2028 :clearline 0x20a8 :clearline 0x2128 :clearline
0x21a8 :clearline 0x2228 :clearline 0x22a8 :clearline
0x2328 :clearline 0x23a8 :clearline 0x2050 :clearline
(center "JAYE AND GORD HAVE FOUND THEIR WAY" 0x2300)
(center "TO THE ELEVATOR!" 0x2380)
(center "BUT HAVE THEY FOUND THEIR WAY" 0x2028)
(center "TO FREEDOM?" 0x20a8)
(center "ARE THERE OTHERS IN THE BUILDING" 0x2128)
(center "IN NEED OF HELP?" 0x21a8)
(center "AND WHAT FATE AWAITS NEUT AND THEIR" 0x2228)
(center "SHIFTY NEW FRIEND LIBB?" 0x22a8)
(center "TO BE CONTINUED..." 0x23a8)
(vm:until :read-key)
:cleargfx
(center "NEU] [OWER" 0x2300)
(center "BY JEREMY PENNER" 0x2380)
(center "EVERY BYTE OF THIS GAME WAS CREATED" 0x20a8)
(center "WITH LOVE USING THE HONEYLISP" 0x2128)
(center "PROGRAMMING ENVIRONMENT" 0x21a8)
(center "GREETS TO:" 0x22a8)
(center "GLORIOUS TRAINWRECKS" 0x2328)
(center "DIRTY RECTANGLES" 0x23a8)
(center "#FENNEL" 0x2050)
(center "KANSASFEST" 0x20d0)
(center "APPLE ][ FOREVER!" 0x21d0)
(vm:forever))
level

39
neuttower/map.fnl
View file

@ -1,39 +0,0 @@
(local {: lo : hi} (require :lib.util))
(local {: vm : mapw : maph : rot8l} (require :neuttower.defs))
(vm:def :lookup-flags ; itile -- flags
[:lda vm.TOP :x]
(rot8l 3) ; lllhhhhh > hhhhhlll
[:adc #(lo ($1:lookup-addr :tileflags))]
[:sta vm.W]
[:lda #(hi ($1:lookup-addr :tileflags))]
[:adc 0]
[:sta vm.WH]
[:ldy 0] [:lda [vm.W] :y]
[:sta vm.TOP :x])
(vm:def :map-at ; yx -- pmap
[:lda (- maph 1)]
[:sec]
[:sbc vm.TOPH :x]
[:asl :a] ; x2
[:asl :a] ; x4
[:sta vm.TOPH :x]
[:asl :a] ; x8
[:asl :a] ; x16
[:clc] [:adc vm.TOPH :x] ; x20
[:adc vm.TOP :x]
[:sta vm.TOP :x]
[:lda :map-page]
[:sta vm.TOPH :x])
(vm:word :itile-at ; yx -- itile
:map-at :bget)
(vm:word :update-itile ; yx itile --
:over :map-at :bset :drawtile-at)
(vm:word :drawtile-at ; yx --
:dup :yx>screen :swap
:itile-at :lookup-tile
:drawtile)

187
neuttower/player.fnl
View file

@ -1,187 +0,0 @@
(local tile (require :game.tiles))
(local {: vm : mapw : maph : itile : controlstate} (require :neuttower.defs))
(local {: walkable : neutable : debris : sittable} (tile.flag-to-bit))
(vm:word :either= ; target val1 val2 -- f
:>rot :over := :>rot := :|)
(vm:word :movement-dir ; key -- dyx
(vm:ifchain [:dup (string.byte "I") 0x0b :either=] [:drop 0xff00]
[:dup (string.byte "J") 0x08 :either=] [:drop 0x00ff]
[:dup (string.byte "K") 0x15 :either=] [:drop 0x0001]
[:dup (string.byte "M") 0x0a :either=] [:drop 0x0100]
[:drop 0x0000]))
(vm:def :yx+ ; yx yx -- yx
[:lda vm.TOP :x]
[:clc] [:adc vm.ST1 :x]
[:sta vm.ST1 :x]
[:lda vm.TOPH :x]
[:clc] [:adc vm.ST1H :x]
[:sta vm.ST1H :x]
(vm:drop))
(vm:var :jaye-yx 0x0a0a)
(vm:var :jaye-dir 0xff00)
(vm:var :neut-yx 0x0b08)
(vm:var :rexx-yx 0xffff)
(vm:var :gord-yx 0xffff)
(vm:var :gord-dir 0x0000)
(vm:var :gord-sitting vm.false)
(vm:var :libb-yx 0xffff)
(vm:var :libb-present vm.false)
(vm:var :controlstate [:db controlstate.jaye])
(vm:word :is-jaye? :controlstate :bget controlstate.jaye :=)
(vm:word :is-neut? :controlstate :bget controlstate.neut :=)
(vm:word :is-rexx? :controlstate :bget controlstate.rexx :=)
(vm:word :is-prog? :is-neut? :is-rexx? :|)
(vm:word :is-walking? :movable-player-flag walkable :=)
(vm:word :neut-hidden? :neut-yx :get 0xffff :=)
(vm:word :rexx-active? :rexx-yx :get 0xffff := :not)
(vm:word :gord-hidden? :gord-yx :get 0xffff :=)
(vm:word :gord-following? :gord-hidden? :gord-sitting :get :| :not)
(vm:word :libb-hidden? :libb-yx :get 0xffff :=)
(vm:word :set-rexx ; e --
:dup (vm:if [:get controlstate.rexx] [:drop 0xffff controlstate.neut])
:controlstate :bset :rexx-yx :set)
(vm:word :player-tile ; -- ptile
:controlstate :bget
(vm:case [controlstate.jaye :jaye-tile]
[controlstate.neut :neut-tile]
[controlstate.gord :gord-tile]
[controlstate.libb :libb-tile]
[:else (itile :t-rexx)]) :lookup-tile)
(vm:word :player-yx ; -- pyx
:controlstate :bget
(vm:case [controlstate.jaye :jaye-yx]
[controlstate.neut :neut-yx]
[controlstate.gord :gord-yx]
[controlstate.libb :libb-yx]
[:else :rexx-yx]))
(vm:word :draw-player ; --
:player-yx :dup (vm:if [:get :dup 0xffff := (vm:if [:drop] [:yx>screen :player-tile :drawtile])] [:drop]))
(vm:word :set-player-dir ; dir --
:is-jaye? (vm:if [:jaye-dir :set] [:drop]))
(vm:var :noclip)
(vm:word :move-if-clear ; yx -- f
:noclip :get (vm:if [:drop vm.false] [:movable-player-flag :flag-at? :not]))
(vm:word :movable-player-flag ; -- flag
:is-neut? (vm:if [neutable] [walkable]))
(vm:word :move-player-to ; yx --
:player-yx :dup :get :dup 0xffff := (vm:if [:drop] [:drawtile-at])
:set :draw-player)
(vm:word :transition-gord-sitting ; yx f --
controlstate.gord :controlstate :bset
:gord-sitting :set :move-player-to
controlstate.jaye :controlstate :bset)
(vm:word :move-rexx-trash ; yx -- f
(vm:if-and [[:dup debris :flag-at?] [:is-rexx?]]
[(itile :t-floor) :update-itile :snd-garbage] [:drop])
vm.false)
(vm:word :move-gord-sit ; yx -- f
(vm:if-and [[:dup sittable :flag-at?] [:is-jaye?] [:gord-following?]]
[vm.true :transition-gord-sitting vm.true]
[:move-noop]))
(vm:word :move-gord-stand ; yx -- f
(vm:if-and [[:gord-yx :get :=] [:is-jaye?] [:gord-sitting :get]]
[:jaye-yx :get vm.false :transition-gord-sitting 0 :gord-dir :set vm.true]
[vm.false]))
(vm:word :move-noop :drop vm.false)
(vm:word :handle-general-move ; yx -- f
(vm:if-or [[:dup :map-specific-move] [:dup :move-rexx-trash] [:dup :move-gord-sit] [:dup :move-gord-stand] [:dup :move-if-clear]]
[:drop vm.true] [:move-noop]))
(vm:def :yxclip? ; yx -- f
[:block
[:lda vm.TOP :x]
[:cmp mapw]
[:bcs :clipped]
[:lda vm.TOPH :x]
[:cmp maph]
[:bcs :clipped]
[:lda 0] [:sta vm.TOP :x] [:sta vm.TOPH :x] (vm:ret)
:clipped
[:lda 0xff] [:sta vm.TOP :x] [:sta vm.TOPH :x]])
(vm:word :try-move-player ; dir --
:dup :set-player-dir ; dir
:player-yx :get :yx+ ; yxnew
(vm:if-or [[:dup :yxclip?] [:dup :touch-entity] [:dup :handle-general-move]]
[:drop :player-yx :get])
; always "move" so that player can visibly change direction
; touch-entity can modify player-yx so we have to refetch
:move-player-to)
(vm:word :jaye-tile ; ptile
:jaye-dir :get
(vm:case [0xff00 (itile :jaye-n)]
[0x0100 (itile :jaye-s)]
[0x00ff (itile :jaye-w)]
[:else (itile :jaye-e)]))
(vm:word :gord-tile ; ptile
:gord-sitting :get
(vm:if [(itile :gord-sit)]
[:gord-dir :get
(vm:case [0xff00 (itile :gord-n)]
[0x0100 (itile :gord-s)]
[0x00ff (itile :gord-w)]
[:else (itile :gord-e)])]))
(vm:var :chuck-mode vm.false)
(vm:word :two-frame :tick-count :get 0x1f :& 0x10 :<)
(vm:word :neut-tile :two-frame :chuck-mode :get (vm:if
[(vm:if [(itile :t-chuck)] [(itile :t-chuck2)])]
[(vm:if [(itile :neut1)] [(itile :neut2)])]))
(vm:word :libb-tile :two-frame (vm:if [(itile :libb1)] [(itile :libb2)]))
(vm:word :flag-at? ; yx flag -- f
:swap :itile-at :lookup-flags :&)
(vm:word :toggle-player
(vm:ifchain [:is-prog?] [controlstate.jaye]
[:rexx-active?] [controlstate.rexx]
[:neut-hidden?] [controlstate.jaye]
[controlstate.neut]) :controlstate :bset
:is-prog? (vm:if [:set-prog-tileset] [:set-human-tileset]) :full-redraw)
(vm:word :party-follow
(vm:if-and [[:is-jaye?] [:gord-following?]]
[controlstate.gord :controlstate :bset
:gord-yx :get :gord-dir :get :yx+ :move-player-to
:jaye-dir :get :gord-dir :set
controlstate.jaye :controlstate :bset]))
(vm:word :player-key ; key --
(vm:ifchain
[:dup (string.byte " ") :=] [:drop :toggle-player]
[:dup (string.byte "Z") :=] [:drop :trigger-sidekick]
[:dup 2 :=] [:drop :boss-key]
[:movement-dir :dup]
[:player-yx :get :swap ; oldyx dir
:try-move-player
:dup :player-yx :get := (vm:if [:drop] [:party-follow :untouch-entity :load-next-level])]
[:drop]))
(vm:word :full-redraw :drawmap :player-redraw)
(vm:word :player-overlaps ; -- f
vm.false :controlstate :bget :player-yx :get
:over (vm:for (vm:i) :controlstate :bset :dup :player-yx :get := (vm:when :<rot :drop vm.true :>rot))
:drop :controlstate :bset)
(vm:word :player-redraw
:controlstate :bget
controlstate.count (vm:for (vm:i) :controlstate :bset :player-overlaps :not (vm:when :draw-player))
:controlstate :bset)

84
neuttower/tiles.fnl
View file

@ -1,84 +0,0 @@
(local util (require :lib.util))
(local lume (require :lib.lume))
(local flags [:walkable :neutable :debris :sittable])
(local flag-to-bit {})
(each [iflag flag (ipairs flags)]
(tset flag-to-bit flag (bit.lshift 1 (- iflag 1))))
(local encoded-tile-fields [:gfx :neut :mask])
(fn convert [tile field method]
(local oldval (. tile field))
(when oldval
(tset tile field (: oldval method)))
tile)
(fn convert-all [tile method]
(each [_ field (ipairs encoded-tile-fields)]
(convert tile field method))
tile)
(fn deserialize [tile]
(match (type tile)
:string {:gfx (tile:fromhex) :flags {}}
:table (convert-all tile :fromhex)))
(fn serialize [tile] (convert-all (lume.clone tile) :tohex))
(local fn-tiles "game/tiles.json")
(local fn-portraits "game/portraits.json")
(local fn-font "game/font.json")
(fn loadgfx [filename] (lume.map (util.readjson filename) deserialize))
(fn savegfx [filename gfx] (util.writejson filename (lume.map gfx serialize)))
(fn appendgfx [org gfx ?key ?ignore-labels]
(each [_ g (ipairs gfx)]
(when (and g.label (not ?ignore-labels)) (org:append g.label))
(org:append [:bytes (. g (or ?key :gfx))])))
(fn appendtiles [org]
(local tiles (loadgfx fn-tiles))
(org:append [:align 0x100] :jaye-tileset)
(appendgfx org tiles)
(org:append [:align 0x100] :neut-tileset)
(appendgfx org tiles :neut true)
(appendgfx org (loadgfx fn-portraits))
(org:append :tileflags)
(each [_ tile (ipairs tiles)]
(var flags 0)
(each [flag _ (pairs tile.flags)]
(set flags (bit.bor flags (. flag-to-bit flag))))
(org:append [:db flags])))
(fn append-portraitwords [vm ?overrides]
(local overrides (or ?overrides {}))
(each [_ p (ipairs (loadgfx fn-portraits))]
(let [wordname (.. :draw- p.label)
override (. overrides p.label)]
(vm:word (.. :draw- p.label) :show-footer
(if override (override p.label) [:vm :lit p.label])
:draw-portrait))))
(fn encode-yx [xy]
(if xy (bit.bor (bit.lshift (- xy.y 1) 8) (- xy.x 1)) 0xffff))
(fn encode-itile [itile]
(bit.bor
(bit.lshift (bit.band (- itile 1) 0x07) 5)
(bit.rshift (bit.band (- itile 1) 0xf8) 3)))
(fn decode-itile [enctile]
(+ 1 (bit.bor
(bit.lshift (bit.band enctile 0x1f) 3)
(bit.rshift (bit.band enctile 0xe0) 5))))
(fn find-itile [tiles label ?itilenext]
(local itile (or ?itilenext 1))
(local tile (. tiles itile))
(assert (not= tile nil) (.. "No such tile " label))
(if (= tile.label label) (encode-itile itile)
(find-itile tiles label (+ itile 1))))
{: loadgfx : savegfx : appendtiles : appendgfx : append-portraitwords : flags : flag-to-bit : find-itile
: fn-tiles : fn-portraits : fn-font : encode-yx : encode-itile : decode-itile}

1
neuttower/title.screen
View file

File diff suppressed because one or more lines are too long

37
presentation/commands.fnl
View file

@ -1,37 +0,0 @@
(local util (require :lib.util))
(local core (require :core))
(local command (require :core.command))
(local keymap (require :core.keymap))
(local style (require :core.style))
(local SlideshowView (require :presentation.engine))
(fn set-scale [multiplier]
(set _G.SCALE (* (love.graphics.getDPIScale) multiplier))
(util.hotswap :core.style)
(when (= multiplier 1)
(set style.code_font (renderer.font.load (.. EXEDIR "/data/fonts/monospace.ttf") 15))))
(command.add nil {
"presentation:start" (fn []
(let [node (core.root_view:get_active_node)]
(node:add_view (SlideshowView (util.reload :presentation.slides))))
)
"presentation:scale-up" #(set-scale 2)
"presentation:restore-scale" #(set-scale 1)
})
(command.add :presentation.engine {
"presentation:next" #(core.active_view:advance)
"presentation:prev" #(core.active_view:back)
"presentation:next-slide" #(core.active_view:next-slide)
"presentation:prev-slide" #(core.active_view:prev-slide)
"presentation:toggle-timer" #(core.active_view:toggle-timer)
"presentation:reset-timer" #(core.active_view:reset-timer)
})
(keymap.add {
"left" "presentation:prev"
"right" "presentation:next"
"ctrl+left" "presentation:prev-slide"
"ctrl+right" "presentation:next-slide"
"alt+t" "presentation:toggle-timer"
})

186
presentation/engine.fnl
View file

@ -1,186 +0,0 @@
(local lume (require :lib.lume))
(local style (require :core.style))
(local common (require :core.common))
(local View (require :core.view))
(local {: attach-imstate : textbutton} (require :editor.imstate))
(local SlideshowView (View:extend))
(fn SlideshowView.parse [slides]
(var style nil)
(icollect [_ slide (ipairs slides)]
(icollect [_ elem (ipairs slide)]
(match (type elem)
(where :table elem.style) (do (set style elem) nil)
:table (if elem.button (lume.merge style elem) elem)
:string (lume.merge style {:text elem})))))
(fn slides-target [slides]
(var target 0)
(each [_ slide (ipairs slides)]
(each [_ elem (ipairs slide)]
(when elem.target (set target (+ target elem.target)))))
target)
(fn SlideshowView.new [self slides]
(SlideshowView.super.new self)
(attach-imstate self)
(set self.slides slides)
(set self.total-target (slides-target slides))
(set self.imagecache {})
(set self.islide 1)
(set self.ielem 0)
(set self.cleanup {})
(self:cleanup-slide)
(self:advance))
(fn SlideshowView.cleanup-slide [self]
(each [_ f (pairs self.cleanup)] (f))
(set self.cleanup {})
(set self.current-target (slides-target (lume.slice self.slides 1 self.islide)))
(set self.sections (icollect [_ slide (ipairs self.slides)]
(let [{: section} (or (lume.match slide #$1.section) {})] section)))
(var isection-current 0)
(set self.islide-to-isection (icollect [_ slide (ipairs self.slides)]
(let [{: section} (or (lume.match slide #$1.section) {})]
(when section (set isection-current (+ isection-current 1)))
isection-current))))
(fn SlideshowView.next-slide [self]
(set self.islide (if (>= self.islide (length self.slides)) 1 (+ self.islide 1)))
(set self.ielem 0)
(self:cleanup-slide)
(self:advance))
(fn SlideshowView.prev-slide [self]
(set self.islide (if (<= self.islide 1) (length self.slides) (- self.islide 1)))
(set self.ielem (+ 1 (length (. self.slides self.islide))))
(self:cleanup-slide)
(self:back))
(fn SlideshowView.ielemNext [self ielem di]
(let [slide (. self.slides self.islide)
elem (. slide ielem)]
(when elem
(when elem.action
(if (= di 1) (tset self.cleanup ielem (elem:action))
(. self.cleanup ielem) ((. self.cleanup ielem))))
(if elem.pause-after ielem
(self:ielemNext (+ ielem di) di)))))
(fn SlideshowView.advance [self]
(let [ielemNext (self:ielemNext (+ self.ielem 1) 1)]
(if ielemNext (set self.ielem ielemNext)
(self:next-slide))))
(fn SlideshowView.back [self]
(let [ielemNext (self:ielemNext (- self.ielem 1) -1)]
(if ielemNext (set self.ielem ielemNext)
(self:prev-slide))))
(fn SlideshowView.load-image [self {:image filename}]
(when (= (. self.imagecache filename) nil)
(tset self.imagecache filename (love.graphics.newImage filename)))
(. self.imagecache filename))
(fn SlideshowView.justify [self element width]
(match element.justify
:center (/ (- self.size.x width) 2)
:right (- self.size.x width style.padding.x)
_ style.padding.x))
(fn SlideshowView.this-y [self element y]
(if element.topPadding (+ y element.topPadding)
(+ y style.padding.y)))
(fn SlideshowView.next-y [self element height y]
(if element.lowerPadding (+ y height element.lowerPadding)
element.overlay y
(+ y height style.padding.y)))
(fn SlideshowView.word-wrap [self element]
(let [letter-width (element.font:get_width "m")
screen-width (- self.size.x style.padding.x style.padding.x)
max-letters (math.floor (/ screen-width letter-width))
wrapped (lume.wordwrap element.text max-letters)
lines (icollect [line (string.gmatch wrapped "([^\n]+)")] line)]
lines))
(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))
element.text
(let [lines (self:word-wrap element)
line-height (element.font:get_height)
full-height (+ (* line-height (length lines)) (* style.padding.y (- (length lines) 1)))]
(each [iline line (ipairs lines)]
(let [width (element.font:get_width line) ;; todo: word-wrapping
x (+ self.position.x (self:justify element width))
yline (+ y (* (+ (element.font:get_height) style.padding.y) (- iline 1)))]
(renderer.draw_text element.font line x yline element.color)))
(self:next-y element full-height y))
element.image
(let [image (self:load-image element)
x (+ self.position.x (self:justify element (image:getWidth)))]
(love.graphics.setColor 1 1 1 element.alpha)
(love.graphics.draw image x y)
(self:next-y element (image:getHeight) y))
y))
(fn SlideshowView.draw [self]
(self:draw_background style.background)
(var y self.position.y)
(each [ielem element (ipairs (. self.slides self.islide)) :until (> ielem self.ielem)]
(set y (self:render-element element (self:this-y element y)))))
; timer
(fn SlideshowView.elapsed [self]
(if self.elapsed-time self.elapsed-time
self.start-time (- (system.get_time) self.start-time)
0))
(fn SlideshowView.toggle-timer [self]
(if (= self.start-time nil)
(set self.start-time (system.get_time))
(= self.elapsed-time nil)
(set self.elapsed-time (self:elapsed))
(do (set self.start-time (- (system.get_time) self.elapsed-time))
(set self.elapsed-time nil))))
(fn SlideshowView.reset-timer [self]
(set self.elapsed-time nil)
(set self.start-time nil))
(fn time [seconds]
(let [sign (if (< seconds 0) "-" "")
seconds (math.abs seconds)
m (math.floor (/ seconds 60))
s (% seconds 60)]
(string.format "%s%d:%02d" sign m s)))
; status bar
(fn SlideshowView.status_items [self {: separator : separator2}]
(let [full (renderer.font.load "presentation/font/PrintChar21.ttf" (* 14 SCALE))
thin (renderer.font.load "presentation/font/PRNumber3.ttf" (* 14 SCALE))
elapsed (self:elapsed)
left [full "\xE2\x8C\xA5 " thin]
right [thin (time (- self.total-target elapsed))
full " \xE2\x8C\x9B "
thin (time (- self.current-target elapsed))]]
(each [isection section (ipairs self.sections)]
(when (> isection 1) (lume.push left style.dim " > "))
(lume.push left (if (= isection (. self.islide-to-isection self.islide)) style.text style.dim) section))
(values left right)))
(fn SlideshowView.get_name [self] "] KFest 2021")
SlideshowView

20
presentation/font/FreeLicense.txt
View file

@ -1,20 +0,0 @@
KREATIVE SOFTWARE RELAY FONTS FREE USE LICENSE
version 1.2f
Permission is hereby granted, free of charge, to any person or entity (the "User") obtaining a copy of the included font files (the "Software") produced by Kreative Software, to utilize, display, embed, or redistribute the Software, subject to the following conditions:
1. The User may not sell copies of the Software for a fee.
1a. The User may give away copies of the Software free of charge provided this license and any documentation is included verbatim and credit is given to Kreative Korporation or Kreative Software.
2. The User may not modify, reverse-engineer, or create any derivative works of the Software.
3. Any Software carrying the following font names or variations thereof is not covered by this license and may not be used under the terms of this license: Jewel Hill, Miss Diode n Friends, This is Beckie's font!
3a. Any Software carrying a font name ending with the string "Pro CE" is not covered by this license and may not be used under the terms of this license.
4. This license becomes null and void if any of the above conditions are not met.
5. Kreative Software reserves the right to change this license at any time without notice.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NONINFRINGEMENT OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF THE USE OR INABILITY TO USE THE SOFTWARE OR FROM OTHER DEALINGS IN THE SOFTWARE.

BIN
presentation/font/PRNumber3.ttf
View file

Binary file not shown.

BIN
presentation/font/PrintChar21.ttf
View file

Binary file not shown.

BIN
presentation/font/Shaston320.ttf
View file

Binary file not shown.

BIN
presentation/font/Shaston640.ttf
View file

Binary file not shown.

BIN
presentation/font/ShastonHi320.ttf
View file

Binary file not shown.

BIN
presentation/font/ShastonHi640.ttf
View file

Binary file not shown.

BIN
presentation/pics/assembly-markup.png
View file

Binary file not shown.
Side by side

Before

Width:  |  Height:  |  Size: 29 KiB

BIN
presentation/pics/beneath-apple-prodos.png
View file

Binary file not shown.
Side by side

Before

Width:  |  Height:  |  Size: 250 KiB

BIN
presentation/pics/bitsy.png
View file

Binary file not shown.
Side by side

Before

Width:  |  Height:  |  Size: 62 KiB

BIN
presentation/pics/boot-tower.jpeg
View file

Binary file not shown.
Side by side

Before

Width:  |  Height:  |  Size: 179 KiB

BIN
presentation/pics/bsod.png
View file

Binary file not shown.
Side by side

Before

Width:  |  Height:  |  Size: 44 KiB

BIN
presentation/pics/ggj2020.jpeg
View file

Binary file not shown.
Side by side

Before

Width:  |  Height:  |  Size: 283 KiB

BIN
presentation/pics/pete286.jpeg
View file

Binary file not shown.
Side by side

Before

Width:  |  Height:  |  Size: 360 KiB

BIN
presentation/pics/retro-game-dev-quote.png
View file

Binary file not shown.
Side by side

Before

Width:  |  Height:  |  Size: 27 KiB

BIN
presentation/pics/thinkhard.png
View file

Binary file not shown.
Side by side

Before

Width:  |  Height:  |  Size: 306 KiB

214
presentation/slides.fnl
View file

@ -1,214 +0,0 @@
(local util (require :lib.util))
(local lume (require :lib.lume))
(local {: parse} (util.require :presentation.engine))
(local core (require :core))
(local style (require :core.style))
(local TileEditView (require :editor.tileedit))
(local MapEditView (require :editor.mapedit))
(local PortraitEditView (require :editor.portraitedit))
(local FontEditView (require :editor.fontedit))
(local ScreenEditView (require :editor.screenedit))
(local files (require :game.files))
(local link (require :link))
(local h
{:style true
:font (renderer.font.load "presentation/font/PrintChar21.ttf" 64)
:color style.caret
:justify :center
:topPadding 14
:lowerPadding 64})
(local **
{:style true
:font (renderer.font.load "presentation/font/PRNumber3.ttf" 32)
:color style.text
: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 bgimg [filename] {:image filename :justify :center :overlay true :alpha 0.3 :topPadding 0})
(fn view-cleanup [view]
(let [root core.root_view.root_node
node (root:get_node_for_view view)]
(when node (node:close_active_view root))))
(fn split-and-open [self f]
(let [focused-view core.active_view
focused-node (core.root_view:get_active_node)
_ (when self.split (focused-node:split self.split))
view (f self)
node (core.root_view:get_active_node)]
(when (= (core.root_view.root_node:get_node_for_view view) nil) (node:add_view view))
(when self.split (core.set_active_view focused-view)) ; don't switch focus
#(view-cleanup view)))
(fn openview [f ?extra] (lume.merge {:action #(split-and-open $1 f)} (or ?extra {})))
(fn openfile [filename ?extra]
(openview #(let [ldoc (core.open_doc filename)
view (core.root_view:open_doc ldoc)]
(when $1.line (view:scroll_to_line $1.line))
view)
?extra))
(fn boot-game []
(let [p (util.reload :game)]
(util.in-coro (fn [] (link:switch :mame)
(link.machine:run)
(util.waitfor #(link.machine:connected?))
(p:upload link.machine)
(link.machine:launch p)))
nil))
(fn vm-eval [...]
(let [prg (require :game)
overlay (prg.vm:gen-eval-prg [:vm ...])]
(link.machine:overlay overlay)
nil))
(parse [
[h "" "" ""
"Honeylisp"
"" "" ""
(np **) "Jeremy Penner"
"https://spindleyq.itch.io/"
"https://blog.information-superhighway.net/"
"https://bitbucket.org/SpindleyQ/honeylisp"
"https://gamemaking.social/@SpindleyQ"
"https://twitter.com/SpindleyQ"
{:pause-after true}
{:target 30 :section :Intro}]
[h "Honeylisp is hard to explain"
** "It is an experimental programming environment designed to enable a productive Apple // game development workflow"
"* Built with https://fennel-lang.org/"
"* Extends the lite text editor https://github.com/rxi/lite"
{:image "presentation/pics/assembly-markup.png" :justify :center}
"* Built all tools from scratch from the assembler up"
"* Not command-line driven - all tools, including the assembler / compiler, run _inside_ the editor"
(openfile :presentation/slides.fnl {:split :right :line 89})
" * Including this presentation!"
{:target 150}]
[(bgimg "presentation/pics/boot-tower.jpeg")
{:action #(files.reload :neuttower/game.json)}
h "Neu] [ower"
** "A small puzzle adventure game!"
"Magic Trick #1: Assemble the game and poke it directly into emulated RAM"
{:action boot-game}
"--== D E M O ==--"
{:target 240}]
[h "Explain this voodoo!"
** "Directly inspired by Dagen Brock's 2016 KFest talk on GSPlus"
"Ended up using MAME - Lua plugin system exposes EVERYTHING"
"Use Jeejah nREPL server library with custom nREPL client"
"The assembler running inside the editor means the output is a rich object, not a file"
{:target 60}]
[h "Hot-Code Reload"
** "What if I could preserve the current runtime state but rewrite the code?"
(openfile :neuttower/level1.fnl {:split :right :line 59})
"Magic Trick #2: Areas of memory can be marked as 'preserved' when new code is uploaded"
{:target 180}]
[(bgimg "presentation/pics/ggj2020.jpeg")
h "Interactive Execution"
** "What if I could interactively try out new code while my game was running?"
(np **) "Magic Trick #3"
{:button #(vm-eval :mixed) :text ":mixed"}
{:button #(vm-eval :hires) :text ":hires"}
{:button #(vm-eval 1 2 :+ :.) :text "1 2 :+ :."}
{:button #(vm-eval :jaye-yx :get :.) :text ":jaye-yx :get :."}
{:button #(vm-eval :earthquake) :text ":earthquake"}
{:pause-after true}
{:target 180}]
[h "The Tools"
** {:image "presentation/pics/retro-game-dev-quote.png" :justify :center :pause-after true}
{:action #(files.reload :neuttower/game.json)}
"14x16 tile editor"
(openview #(TileEditView))
"Font editor"
(openview #(FontEditView))
"Portrait editor"
(openview #(PortraitEditView))
"Map editor"
(openview #(MapEditView))
"Full-screen bitmap editor"
(openview #(ScreenEditView :neuttower/title.screen) {:pause-after true})
{:target 300 :section "Tooling"}]
[h "Editing Editors With My Editor"
** "Lua provides a very dynamic environment"
(openview #(MapEditView))
(openfile :editor/mapedit.fnl {:split :right :line 235})
"Downside:"
{:image "presentation/pics/bsod.png" :justify :center :pause-after true}
{:target 180}]
[(bgimg "presentation/pics/bitsy.png")
{:action #(files.reload :bitsy/game.json)}
h "8-Bitsy"
** "Bitsy is a popular free, accessible, web-based game-making tool"
{:action boot-game}
"Spring Lisp Game Jam - 10 days to hack"
"Could I make my tools a little less... programmer-y?"
(openview #(MapEditView) {:pause-after true})
{:target 180 :section "Branching Out"}]
[h "Thanks!"
(openfile :neuttower/level6.fnl {:split :right :line 164})
(np **) "Questions?"
{:topPadding 128}
"Jeremy Penner"
"https://spindleyq.itch.io/"
"https://blog.information-superhighway.net/"
"https://bitbucket.org/SpindleyQ/honeylisp"
"https://gamemaking.social/@SpindleyQ"
"https://twitter.com/SpindleyQ"
{:pause-after true :section "Thanks!"}]
])
; [(bgimg "presentation/pics/pete286.jpeg")
; h "Some Background"
; ** "2019: Built a 16-bit MS-DOS game engine, using only retro hardware and software."
; " * Driven by a custom Forth interpreter"
; {:target 90}]
; [(bgimg "presentation/pics/ggj2020.jpeg")
; h "Neut Tower"
; ** "2020: Created Neut Tower as part of two game jams.
; * Global Game Jam - One weekend - Feb 2020 - First two rooms
; * MS-DOS Game Jam - 1.5 months - April 2020 - 'Shareware Episode 1'"
; {:target 60}]
; [h "What is this unholy abomination?"
; ** "Lisp and Forth?!"
; {:image "presentation/pics/thinkhard.png" :justify :center}
; "Not super keen on writing a complicated compiler"
; " * \"Direct threaded\" inner interpreter"
; "Forth allows efficient, composable, interactive code"
; {:target 60}]
; [h "Wait WTF Is An Assembler"
; ** "It's just converting mnemonics to bytes, right?"
; "Whoooops, actually the hard part is converting labels to addresses"
; "Zero-page instructions are a different size, which messes up data layout!"
; "Initial pass is needed to gather all symbols to determine sizes"
; {:target 60}]
; [h "Step 5: Running on Hardware"
; ** "I have a IIgs with a serial cable - I can poke bytes in directly from the monitor"
; "]IN#2\n]PR#2\n]CALL-151"
; "Easy to send bytes faster than the monitor can process them"]
; [h "Audio"
; ** "I have a II+ with a cassette port"
; "LÖVE2D is a game engine - my editor can generate audio and play it back immediately"
; "Need to generate a BASIC program to bootstrap my machine code"
; (openfile :asm/tape.fnl {:split :right})
; " [:basic [10 :call :2061]]"
; "Future work: Apple Game Server fastloader"]
; [(bgimg "presentation/pics/beneath-apple-prodos.png")
; h "ProDOS"
; ** "Disk image is a must-have for distribution"
; (openfile :asm/prodos.fnl {:split :right :line 132})
; "Of course I wrote my own disk image generation code!"
; "Start with a blank ProDOS disk and add to it"
; "Fun bugs!"
; "* Accidentally implemented undelete instead of inserting new files at first"
; "* Read the free space bitmap backwards and overwrote the OS"
; "* Tried to name a volume starting with a number"]

12
support/lite/plugins/statusoverride.lua
View file

@ -1,12 +0,0 @@
local core = require "core"
local get_items = core.status_view.get_items
core.status_view.get_items = function (self)
if core.active_view and core.active_view.status_items then
return core.active_view:status_items(self)
else
return get_items(self)
end
end

2
support/mame/jeejah/init.lua
View file

@ -8,7 +8,7 @@ if package.path:find("vendor/jeejah/") == nil then
local fennel = require "fennel" local fennel = require "fennel"
fennel.path = './?.fnl;' .. modpath .. "/../../../vendor/jeejah/?.fnl" fennel.path = './?.fnl;' .. modpath .. "/../../../vendor/jeejah/?.fnl"
table.insert(package.loaders or package.searchers, fennel.make_searcher({correlate=true})) table.insert(package.searchers, fennel.make_searcher({correlate=true}))
end end
local fennel = require "fennel" local fennel = require "fennel"

1
vendor/lite/data/plugins/statusoverride.lua vendored
View file

@ -1 +0,0 @@
../../../../support/lite/plugins/statusoverride.lua

15
wrap.fnl
View file

@ -5,23 +5,8 @@
(require :link.command) (require :link.command)
(local core (require :core)) (local core (require :core))
(local command (require :core.command)) (local command (require :core.command))
(local common (require :core.common))
(local keymap (require :core.keymap)) (local keymap (require :core.keymap))
(local translate (require :core.doc.translate)) (local translate (require :core.doc.translate))
(local files (require :game.files))
(command.add nil {
"honeylisp:open-project" (fn []
(core.command_view:enter "Open Project"
(fn [text item]
(files.reload (or (and item item.text) text))
(core.log "Opened"))
(fn [text]
(local files [])
(each [_ item (pairs core.project_files)]
(when (and (= item.type :file) (item.filename:find "^.*/game%.json"))
(table.insert files item.filename)))
(common.fuzzy_match files text))))})
(command.add #(link.machine:connected?) { (command.add #(link.machine:connected?) {
"honeylisp:upload" (fn [] "honeylisp:upload" (fn []