honeylisp/game/entity.fnl

(local util (require :lib.util))
(local tiles (util.require :game.tiles))
(local {: vm : org : itile : say : say-runon} (require :game.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
  :noop    5
})

(vm:word :entity-count :lit :map-entity-count :bget)
(vm:def :lookup-entity ; i -- entity
  [:lda vm.TOP :x]
  [:asl :a] [:asl :a] [:asl :a] ; x8
  [:sta vm.TOP :x]
  [:lda #(hi org.entity.org)]
  [: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)

(vm:word :handle-onoff ; ev off on --
  :<rot (vm:case
    [ev.act :swap :drop :set-respondertile]
    [ev.deact :drop :set-respondertile]
    [ev.tog :dup :responder-itile := (vm:if [:drop :set-respondertile] [:set-respondertile :drop])]
    [:else :drop :drop]))
(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 :door ; ev --
  (vm:if-and [[:is-walking?] [:dup ev.touch :=] [:responder-itile (itile :dooropen) :=]]
    [:move-to-responder :drop]
    [(itile :doorclosed) (itile :dooropen) :handle-onoff]))

(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:word :term ; ev --
  :dup ev.touch := (vm:when
    (vm:ifchain [:is-jaye?] [:drop ev.act]
                [:is-neut?] [:linked-entity
                             (vm:if-and [[:dup :entity-itile (itile :termon) :=]
                                         [:responder-itile (itile :termon) :=]]
                               [:get :move-player-to] [:drop])]
                []))
  (itile :termoff) (itile :termon) :handle-onoff)

(vm:word :handle-scan ; ev --
  :dup (itile :scanoff) (itile :scanon) :handle-onoff
  :linked-entity :swap :entity>do)

(vm:word :scan ; ev --
  :is-neut? (vm:if [
    (vm:case
      [ev.touch ev.act :handle-scan :move-to-responder]
      [ev.untouch ev.deact :handle-scan]
      [: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]
      [(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)
(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 (itile :t-keyoff) (itile :t-keyon) :handle-onoff
  (itile :t-keyon) :activate-link)

(vm:word :trigger-sidekick
  (vm:if-and [[:is-jaye?] [:gord-sitting :get]]
    [:gord-yx :get ev.touch :entity-around>do]))

(fn append-from-map [map entity-org]
  (each [_ entity (ipairs map.objects)]
    (when entity.name
      (entity-org:append entity.name))
    (entity-org:append
      [: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 [:dw (+ entity-org.org (* (- entity.link 1) 8))] [:dw 0]))))

{: ev : append-from-map}