honeylisp/game/player.fnl

(local tile (require :game.tiles))
(local {: vm : mapw : maph : itile : controlstate} (require :game.defs))

(local {: walkable : neutable : debris : sittable} tile.flag-to-bit)

(vm:word :movement-dir ; key -- dyx
  (vm:case [(string.byte "I") 0xff00]
           [(string.byte "J") 0x00ff]
           [(string.byte "K") 0x0001]
           [(string.byte "M") 0x0100]
           [:else             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 :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: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] [: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-special-move ; yx -- f
  (vm:if-or [[:dup :map-specific-move] [:dup :move-rexx-trash] [:dup :move-gord-sit] [:dup :move-gord-stand]]
    [: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-special-move] [:dup :movable-player-flag :flag-at? :not]]
    [: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:word :two-frame :tick-count :get 0x1f :& 0x10 :<)
(vm:word :neut-tile :two-frame (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]
    [:movement-dir :dup]
    [:player-yx :get :swap ; oldyx dir
     :try-move-player
     :dup :player-yx :get := (vm:if [:drop] [:party-follow :untouch-entity])]
    [:drop]))

(vm:word :full-redraw :drawmap :player-redraw)
(vm:word :player-redraw
  :controlstate :bget
  controlstate.count (vm:for (vm:i) :controlstate :bset :draw-player)
  :controlstate :bset)