235 lines
8.6 KiB
Plaintext
235 lines
8.6 KiB
Plaintext
|
(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}
|
||
|
|
|