experimenting with OpenGOAL accessibility

accessibility.gc

;;-*-Lisp-*-
(in-package goal)

;; "Installing"/testing this mod:
;; Start the game in debug mode:
;;     $ ./build/game/gk --game jak1 -- -boot -debug
;; Start the repl:
;;     $ ./build/goalc/goalc --game jak1
;; Connect to the game and compile/load this script:
;;     gc> (lt)
;;     gc> (ml "accessibility.gc")

;; This can be hooked into the debug menu
(define *display-a11y-marks* #t)

;; WIP
(defun a11y-take-over-camera ()
  ;; stand-off mode means the camera does not rotate
  (send-event *camera* 'change-state cam-standoff *dm-cam-mode-interpolation*)
  ;; we need a way to point the camera in a consistent direction,
  ;; the below does not work
  (let ((poi (new-stack-vector0)))
    (set! (-> poi x) 0.0)
    (set! (-> poi y) 0.0)
    (set! (-> poi z) (meters 100000.0))
    (send-event *camera* 'point-of-interest poi)
    )
    (send-event *camera* 'toggle-slave-option (cam-slave-options STICKY_ANGLE))
  )

(defenum a11y-sense
  :type uint8
  (unknown 0)
  (fall 1)
  (drop-down 2)
  (ground 3)
  (jump-up 4)
  (double-jump-up 5)
  (too-high 6)
  )

;; this does not take slopes into account
(defun a11y-height->sense ((height float))
  (cond
    ((< height (meters -10.0)) (a11y-sense fall))
    ((< height (meters -2.0)) (a11y-sense drop-down))
    ((< height (meters 1.0)) (a11y-sense ground))
    ((< height (meters 3.0)) (a11y-sense jump-up))
    ((< height (meters 5.0)) (a11y-sense double-jump-up))
    ((< height (meters 1000.0)) (a11y-sense too-high))
    (else (a11y-sense unknown))
    )
  )

(defun a11y-play-sound-for-sensor-result ((result a11y-sense))
  (cond
    ((= result (a11y-sense fall)) (sound-play "get-burned"))
    ((= result (a11y-sense drop-down)) (sound-play "cursor-l-r"))
    ((= result (a11y-sense ground)) (sound-play "stopwatch"))
    ((= result (a11y-sense jump-up)) (sound-play "select-option"))
    ((= result (a11y-sense double-jump-up)) (sound-play "start-options"))
    ((= result (a11y-sense too-high)) (sound-play "cursor-options"))
    (else (sound-play "buzzer-pickup"))
    )
  )

(define *a11y-sensor-state* (a11y-sense unknown))

(defun a11y-record-sensor-result ((height-diff float))
  (let ((result (a11y-height->sense height-diff)))
    (when (!= *a11y-sensor-state* result)
      (set! *a11y-sensor-state* result)
      (a11y-play-sound-for-sensor-result result)
      )
    )
  )

(defbehavior a11y-probe-ground target ()
  (let ((origin (new 'static 'vector :y 0.0 :x 0.0 :z 0.0))
        (line (new 'static 'vector :y 0.0 :x 0.0 :z 0.0))
        (radius (meters 1.0))
        (start-height (meters 10.0))
        (lead (meters 5.0))
        (drop (meters 30.0)))

    (set! (-> origin quad) (-> self control trans quad))
    (set! (-> line quad) (-> self control unknown-matrix01 vector 2 quad))
    (vector-float*! line line lead)
    (vector+! origin origin line)
    (set! (-> origin y) (+ (-> origin y) start-height))
    (set! (-> line quad) (the-as uint128 0))
    (set! (-> line y) (- drop))

    (add-debug-line
      *display-a11y-marks*
      (bucket-id debug-no-zbuf)
      origin
      (vector+! (new 'stack-no-clear 'vector) origin line)
      (new 'static 'rgba :r #x80)
      #f
      (the rgba -1)
      )
    (dotimes (i 10)
      (add-debug-sphere
        *display-a11y-marks*
        (bucket-id debug-no-zbuf)
        (vector-lerp! (new 'stack-no-clear 'vector)
                      origin
                      (vector+! (new 'stack-no-clear 'vector) origin line)
                      (/ (the float i) 9.0)
                      )
        radius
        (new 'static 'rgba :g #x80 :r #x80 :b #x80 :a #x80)
        )
      )
    (let ((probe-result (new 'stack-no-clear 'collide-tri-result)))
      (let ((dist (fill-and-probe-using-line-sphere
                    *collide-cache*
                    origin
                    line
                    radius
                    (collide-kind
                      cak-1 cak-2
                      background water
                      powerup
                      crate
                      enemy
                      wall-object ground-object
                      )
                    (the process-drawable #f)
                    probe-result
                    (new 'static 'pat-surface :noentity #x1)
                    )
            ))
        (let ((mode (-> probe-result pat mode))
              (material (-> probe-result pat material))
              (event (-> probe-result pat event))
              (height (- 0.0 (- (* dist drop) (- start-height radius)))))
          (let ((hit (<= 0.0 dist)))
            (if hit
              (a11y-record-sensor-result height)
              (a11y-record-sensor-result (meters -1000.0))
              )
            hit
            )
          )
        )
      )
    )
  )

;; Our hook, to be run periodically
(defbehavior a11y-target-post target ()
  (a11y-probe-ground)
  )

;; Hook the "mod" into the game

;;This doesn't work:
;;(defbehavior target-post target ()
;;  (target-real-post)
;;  (a11y-target-post)
;;  (none)
;;  )
(defbehavior post-flag-setup target ()
  (if (logtest? (-> self control status) (cshape-moving-flags twall t-act))
      (set! (-> self control unknown-dword20) (-> *display* base-frame-counter))
      )
  (when (logtest? (-> self state-flags) (state-flags timed-invulnerable))
    ;; changed for high fps. This fixes the flicker speed when damaged
    (if (< (logand (- (-> *display* base-frame-counter) (-> self control unknown-dword80)) 3) (/ 1.0 (-> *display* time-adjust-ratio)))
        (logior! (-> self draw status) (draw-status hidden))
        (logclear! (-> self draw status) (draw-status hidden))
        )
    (if (>= (- (-> *display* base-frame-counter) (-> self control unknown-dword80)) (-> self control unknown-dword81))
        (target-timed-invulnerable-off self)
        )
    )
  (set! (-> self control unknown-symbol40) #f)
  0
  (a11y-target-post)
  (none)
  )