mirror of
https://github.com/open-goal/jak-project
synced 2026-08-07 02:06:59 -04:00
water111
1019 lines
47 KiB
Common Lisp
1019 lines
47 KiB
Common Lisp
;;-*-Lisp-*-
|
|
(in-package goal)
|
|
(bundles "ENGINE.CGO" "GAME.CGO")
|
|
(require "engine/gfx/hw/display.gc")
|
|
(require "engine/gfx/font.gc")
|
|
|
|
;; This file contains the UI and rendering for the debug menu, but not the actual menu layout and callbacks.
|
|
|
|
;; The "context" is the entire multi-level debug menu. There's a separate context for the main debug and the "popup" menu.
|
|
;; A "menu" is a listing of "items".
|
|
;; An item is a line in the menu. It can be a flag, function, or variable.
|
|
|
|
(declare-type debug-menu basic)
|
|
|
|
(declare-type debug-menu-item basic)
|
|
|
|
;; DECOMP BEGINS
|
|
|
|
;; this file is debug only
|
|
(declare-file (debug))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; context, menu, and item
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; There is one for the normal menu, and one for the "popup" one that appears when you press L3/R3
|
|
;; This stores a stack of open menus in sel-menu.
|
|
;; The 0th index is the selection in the root-menu.
|
|
(deftype debug-menu-context (basic)
|
|
((is-active symbol) ;; should we draw?
|
|
(sel-length int32) ;; depth of open menus
|
|
(sel-menu debug-menu 8) ;; at each level, what is selected?
|
|
(root-menu debug-menu) ;; the top level menu
|
|
(joypad-func (function basic none)) ;; if not, #f, callback for getting joystick inputs
|
|
(joypad-item basic) ;; object passed as arg to joypad-func
|
|
(font font-context) ;; font rendering settings
|
|
(is-hidden symbol) ;; set to #t to temporarily hide.
|
|
)
|
|
(:methods
|
|
(new (symbol type) _type_)))
|
|
|
|
(defmethod new debug-menu-context ((allocation symbol) (type-to-make type))
|
|
"Create a new debug-menu-context"
|
|
(let ((context (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
|
|
(set! (-> context is-active) #f)
|
|
(set! (-> context is-hidden) #f)
|
|
(set! (-> context sel-length) 0)
|
|
(set! (-> context root-menu) #f)
|
|
(set! (-> context joypad-func) #f)
|
|
(set! (-> context joypad-item) #f)
|
|
;; og:preserve-this added pc-hack flag
|
|
(set! (-> context font)
|
|
(new 'debug 'font-context *font-default-matrix* 0 0 0.0 (font-color default) (font-flags shadow kerning pc-hack)))
|
|
context))
|
|
|
|
;; Parent type for entrees in the debug-menu tree.
|
|
;; This is used for both entries and menus.
|
|
|
|
;; Items will be periodically "refreshed" to update their color/status.
|
|
;; Updating every item on every frame would be slow, so you can set a nonzero value in refresh-delay
|
|
;; to only run the refresh every refresh-delay frames.
|
|
(deftype debug-menu-node (basic)
|
|
((name string)
|
|
(parent debug-menu)
|
|
(refresh-delay int32)
|
|
(refresh-ctr int32)))
|
|
|
|
(defmethod print ((this debug-menu-node))
|
|
(format #t "#<~A ~A @ #x~X>" (-> this type) (-> this name) this)
|
|
this)
|
|
|
|
;; Parent type for a menu (list of things)
|
|
(deftype debug-menu (debug-menu-node)
|
|
((context debug-menu-context)
|
|
(selected-item debug-menu-item)
|
|
(pix-width int32)
|
|
(pix-height int32)
|
|
(items pair))
|
|
(:methods
|
|
(new (symbol type debug-menu-context string) _type_)))
|
|
|
|
(defmethod new debug-menu ((allocation symbol) (type-to-make type) (context debug-menu-context) (name string))
|
|
"Create a new debug-menu"
|
|
(let ((menu (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
|
|
(set! (-> menu context) context)
|
|
(set! (-> menu name) name)
|
|
(set! (-> menu parent) #f)
|
|
(set! (-> menu selected-item) #f)
|
|
(set! (-> menu items) '())
|
|
menu))
|
|
|
|
;; Parent type for an item (an individual, selectable entry within a menu)
|
|
(deftype debug-menu-item (debug-menu-node)
|
|
((id int32)))
|
|
|
|
(deftype debug-menu-item-submenu (debug-menu-item)
|
|
((submenu debug-menu))
|
|
(:methods
|
|
(new (symbol type string debug-menu) _type_)))
|
|
|
|
(defmethod new debug-menu-item-submenu ((allocation symbol) (type-to-make type) (name string) (menu debug-menu))
|
|
"Create an item that opens the given menu."
|
|
(let ((item (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
|
|
(set! (-> item name) name)
|
|
(set! (-> item parent) #f)
|
|
(set! (-> item refresh-delay) 0)
|
|
(set! (-> item refresh-ctr) (-> item refresh-delay))
|
|
(set! (-> item submenu) menu)
|
|
;; in this case, the submenu's parent is set to the item, not a menu.
|
|
;; it's possible that the type of parent here is just debug-menu-node, but this value is never used.
|
|
(set! (-> item submenu parent) (the-as debug-menu item))
|
|
item))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Items
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(defenum debug-menu-msg
|
|
:type int32
|
|
(activate 1)
|
|
(deactivate 2)
|
|
(update 3)
|
|
(press 4))
|
|
|
|
;; An item that calls a function when you select it.
|
|
(deftype debug-menu-item-function (debug-menu-item)
|
|
((activate-func (function object object))
|
|
(hilite-timer int8) ;; how much longer to stay highlighted for.
|
|
)
|
|
(:methods
|
|
(new (symbol type string object (function object object)) _type_)))
|
|
|
|
(defmethod new debug-menu-item-function ((allocation symbol) (type-to-make type) (name string) (id object) (activate-func (function object object)))
|
|
"Create an item for a function."
|
|
(let ((item (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
|
|
(set! (-> item name) name)
|
|
(set! (-> item parent) #f)
|
|
(set! (-> item refresh-delay) 0)
|
|
(set! (-> item refresh-ctr) (-> item refresh-delay))
|
|
(set! (-> item id) (the-as int id))
|
|
(set! (-> item activate-func) activate-func)
|
|
(set! (-> item hilite-timer) 0)
|
|
item))
|
|
|
|
;; An item with on/off state.
|
|
(deftype debug-menu-item-flag (debug-menu-item)
|
|
((activate-func (function object debug-menu-msg object))
|
|
(is-on object))
|
|
(:methods
|
|
(new (symbol type string object (function object debug-menu-msg object)) _type_)))
|
|
|
|
(defmethod new debug-menu-item-flag ((allocation symbol) (type-to-make type) (name string) (id object) (activate-func (function object debug-menu-msg object)))
|
|
"Create a periodically refreshed flag item whose callback reads or toggles the value."
|
|
(let ((item (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
|
|
(set! (-> item name) name)
|
|
(set! (-> item parent) #f)
|
|
(set! (-> item refresh-delay) 23)
|
|
(set! (-> item refresh-ctr) (-> item refresh-delay))
|
|
(set! (-> item id) (the-as int id))
|
|
(set! (-> item activate-func) activate-func)
|
|
(set! (-> item is-on) (the-as object #f))
|
|
item))
|
|
|
|
(deftype debug-menu-item-var (debug-menu-item)
|
|
((display-str string)
|
|
(grabbed-joypad-p symbol)
|
|
(float-p symbol)
|
|
(range-p symbol)
|
|
(show-len int32)
|
|
(inc-delay int32)
|
|
(inc-delay-ctr int32)
|
|
(step-delay-ctr int32)
|
|
(inc-dir int32)
|
|
(fval float)
|
|
(fundo-val float)
|
|
(frange-min float)
|
|
(frange-max float)
|
|
(fstart-inc float)
|
|
(fstep float)
|
|
(fprecision int32)
|
|
(factivate-func (function int debug-menu-msg float float float))
|
|
(ival int32 :overlay-at fval)
|
|
(iundo-val int32 :overlay-at fundo-val)
|
|
(irange-min int32 :overlay-at frange-min)
|
|
(irange-max int32 :overlay-at frange-max)
|
|
(istart-inc int32 :overlay-at fstart-inc)
|
|
(istep int32 :overlay-at fstep)
|
|
(ihex-p symbol)
|
|
(iactivate-func (function int debug-menu-msg int int int) :overlay-at factivate-func)
|
|
(ifloat-p symbol))
|
|
(:methods
|
|
(new (symbol type string int int) _type_)))
|
|
|
|
(defenum debug-menu-dest
|
|
:type int32
|
|
(root 1)
|
|
(open-menus 2)
|
|
(current-selection 3)
|
|
(activation 0))
|
|
|
|
(define-extern debug-menu-context-send-msg
|
|
(function debug-menu-context debug-menu-msg debug-menu-dest debug-menu-context))
|
|
|
|
(define-extern debug-menu-item-send-msg (function debug-menu-item debug-menu-msg debug-menu-item))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Variable Menu Setup
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun debug-menu-item-var-update-display-str ((item debug-menu-item-var))
|
|
"Update display-str to the current value of the variable"
|
|
(cond
|
|
((-> item float-p) (format (clear (-> item display-str)) "~f" (-> item fval)))
|
|
((-> item ihex-p) (format (clear (-> item display-str)) "x~X" (-> item fval)))
|
|
((-> item ifloat-p)
|
|
(cond
|
|
((and (< (the-as int (-> item fval)) 0) (< -100 (the-as int (-> item fval))))
|
|
(let ((abs-value (abs (the-as int (-> item fval))))) (format (clear (-> item display-str)) "-0.~1d" (/ (mod abs-value 100) 10))))
|
|
(else
|
|
(let ((abs-value (abs (the-as int (-> item fval)))))
|
|
(format (clear (-> item display-str)) "~2d.~1d" (/ (the-as int (-> item fval)) 100) (/ (mod abs-value 100) 10))))))
|
|
(else (format (clear (-> item display-str)) "~D" (-> item fval))))
|
|
item)
|
|
|
|
(defun debug-menu-item-var-make-int ((item debug-menu-item-var)
|
|
(callback (function int debug-menu-msg int int int))
|
|
(inc int)
|
|
(has-range symbol)
|
|
(range-min int)
|
|
(range-max int)
|
|
(hex symbol))
|
|
"Set up the given item as an integer variable"
|
|
(set! (-> item float-p) #f)
|
|
(set! (-> item range-p) has-range)
|
|
(set! (-> item irange-min) range-min)
|
|
(set! (-> item irange-max) range-max)
|
|
(set! (-> item istart-inc) inc)
|
|
(set! (-> item istep) inc)
|
|
(set! (-> item ihex-p) hex)
|
|
(set! (-> item iactivate-func) callback)
|
|
(cond
|
|
(has-range (set! (-> item fval) (the-as float range-min)))
|
|
(else (set! (-> item fval) (the-as float 0)) 0))
|
|
;; initialize with the callback.
|
|
(if callback (set! (-> item ival) (callback (-> item id) (debug-menu-msg update) (-> item ival) (-> item ival))))
|
|
(debug-menu-item-var-update-display-str item)
|
|
item)
|
|
|
|
(defun debug-menu-item-var-make-float ((item debug-menu-item-var)
|
|
(callback (function int debug-menu-msg float float float))
|
|
(inc float)
|
|
(has-range symbol)
|
|
(range-min float)
|
|
(range-max float)
|
|
(precision int))
|
|
"Set up the given item as a float variable"
|
|
(set! (-> item float-p) #t)
|
|
(set! (-> item range-p) has-range)
|
|
(set! (-> item frange-min) range-min)
|
|
(set! (-> item frange-max) range-max)
|
|
(set! (-> item fstart-inc) inc)
|
|
(set! (-> item fstep) inc)
|
|
(set! (-> item fprecision) precision)
|
|
(set! (-> item factivate-func) callback)
|
|
(if has-range (set! (-> item fval) range-min) (set! (-> item fval) 0.0))
|
|
;; The callback result is converted from int to float here even though the callback's
|
|
;; declared result is float.
|
|
(if callback
|
|
(set! (-> item fval) (the float (callback (-> item id) (debug-menu-msg update) (-> item fval) (-> item fval)))))
|
|
(debug-menu-item-var-update-display-str item)
|
|
item)
|
|
|
|
(defmethod new debug-menu-item-var ((allocation symbol) (type-to-make type) (name string) (id int) (max-width int))
|
|
"Create a new item for modifying a variable. Will default to int."
|
|
(let ((item (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
|
|
(let ((max-chars (/ max-width 8)))
|
|
(set! (-> item name) name)
|
|
(set! (-> item parent) #f)
|
|
(set! (-> item refresh-delay) (#if PC_PORT 1 31))
|
|
(set! (-> item refresh-ctr) (-> item refresh-delay))
|
|
(set! (-> item id) id)
|
|
(set! max-chars (if (< 3 max-chars) max-chars 3))
|
|
(set! (-> item show-len) max-chars))
|
|
(set! (-> item grabbed-joypad-p) #f)
|
|
(set! (-> item ifloat-p) #f)
|
|
(set! (-> item display-str) (new 'debug 'string 64 (the-as string #f)))
|
|
(debug-menu-item-var-make-int item (the-as (function int debug-menu-msg int int int) #f) 1 #t 0 0 #f)
|
|
item))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; joypad grabbing
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun debug-menu-context-grab-joypad ((ctxt debug-menu-context) (callback-arg basic) (callback-func (function basic none)))
|
|
"Set up this context to be controlled from a joypad. If we are already, return #f, otherwise return #t"
|
|
(cond
|
|
((-> ctxt joypad-func) #f)
|
|
(else (set! (-> ctxt joypad-func) callback-func) (set! (-> ctxt joypad-item) callback-arg) #t)))
|
|
|
|
(defun debug-menu-context-release-joypad ((ctxt debug-menu-context))
|
|
"Remove joypad control from this context"
|
|
(set! (-> ctxt joypad-func) #f)
|
|
(set! (-> ctxt joypad-item) #f)
|
|
#f)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; menu building
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun debug-menu-item-get-max-width ((item debug-menu-item) (menu debug-menu))
|
|
"Determine the width, in screen units"
|
|
0
|
|
(cond
|
|
((= (-> item type) debug-menu-item-submenu) (+ (the int (get-string-length (-> item name) (-> menu context font))) 16))
|
|
((= (-> item type) debug-menu-item-var)
|
|
(the int (get-string-length (-> (the-as debug-menu-item-var item) display-str) (-> menu context font))))
|
|
(else (+ (the int (get-string-length (-> item name) (-> menu context font))) 6))))
|
|
|
|
(defun debug-menu-context-default-selection ((ctxt debug-menu-context) (keep-current symbol))
|
|
"Set the menu to a default selection.
|
|
If keep-current-selection is set to #t, this will only change the selection if nothing is selected yet."
|
|
;; sel-length = 0 means nothing is selected
|
|
(when (or (zero? (-> ctxt sel-length)) (not keep-current))
|
|
(let ((menu (-> ctxt root-menu)))
|
|
;; check that we have a menu with items
|
|
(when (and menu (not (null? (-> menu items))))
|
|
(let ((currently-active (-> ctxt is-active)))
|
|
;; if we're active, deactivate it
|
|
(if currently-active (debug-menu-context-send-msg ctxt (debug-menu-msg deactivate) (debug-menu-dest activation)))
|
|
;; reset the selection stack down to a single thing, just the root menu.
|
|
(set! (-> ctxt sel-length) 1)
|
|
(set! (-> ctxt sel-menu 0) menu)
|
|
;; select the first thing within the root menu
|
|
(set! (-> menu selected-item) (the-as debug-menu-item (car (-> menu items))))
|
|
;; if we were active, activate again.
|
|
(if currently-active (debug-menu-context-send-msg ctxt (debug-menu-msg activate) (debug-menu-dest activation)))))))
|
|
ctxt)
|
|
|
|
(defun debug-menu-rebuild ((menu debug-menu))
|
|
"Set the width and height of the background. If needed, completely reset the menu."
|
|
(let ((max-width 0)
|
|
(entry-count 0))
|
|
;; loop over entries
|
|
(let* ((iter (-> menu items))
|
|
(current-item (car iter)))
|
|
(while (not (null? iter))
|
|
(+! entry-count 1)
|
|
;; link to parent
|
|
(set! (-> (the-as debug-menu-item current-item) parent) menu)
|
|
(set! max-width (max max-width (debug-menu-item-get-max-width (the-as debug-menu-item current-item) menu)))
|
|
(set! iter (cdr iter))
|
|
(set! current-item (car iter))))
|
|
(set! (-> menu pix-width) (+ max-width 18))
|
|
(set! (-> menu pix-height) (+ (* entry-count 8) 6)))
|
|
(let ((a0-2 (-> menu context)))
|
|
;; will only reset to default if nothing is selected.
|
|
(debug-menu-context-default-selection a0-2 #t))
|
|
menu)
|
|
|
|
(defun debug-menu-context-set-root-menu ((context debug-menu-context) (menu debug-menu))
|
|
"Set the root menu and reset everything."
|
|
;; deactivate, if we are active
|
|
(let ((active (-> context is-active)))
|
|
(if active (debug-menu-context-send-msg context (debug-menu-msg deactivate) (debug-menu-dest activation)))
|
|
;; the actual set
|
|
(set! (-> context root-menu) menu)
|
|
;; reset
|
|
(debug-menu-context-default-selection context #f)
|
|
;; activate if needed
|
|
(if active (debug-menu-context-send-msg context (debug-menu-msg activate) (debug-menu-dest activation))))
|
|
context)
|
|
|
|
(defun debug-menu-append-item ((menu debug-menu) (item debug-menu-node))
|
|
"Add an entry to the debug menu."
|
|
(let* ((context (-> menu context))
|
|
(was-active (-> context is-active)))
|
|
(if was-active (debug-menu-context-send-msg context (debug-menu-msg deactivate) (debug-menu-dest activation)))
|
|
(set! (-> item parent) menu)
|
|
;; og:preserve-this was normal cons
|
|
(set! (-> menu items) (the-as pair (append! (-> menu items) (dcons item '()))))
|
|
(debug-menu-rebuild menu)
|
|
(if was-active (debug-menu-context-send-msg context (debug-menu-msg activate) (debug-menu-dest activation))))
|
|
item)
|
|
|
|
(defun debug-menu-remove-all-items ((menu debug-menu))
|
|
"Remove all the items from a menu"
|
|
(let* ((context (-> menu context))
|
|
(was-active (-> context is-active)))
|
|
(if was-active (debug-menu-context-send-msg context (debug-menu-msg deactivate) (debug-menu-dest activation)))
|
|
(set! (-> menu items) '())
|
|
(set! (-> menu selected-item) #f)
|
|
(debug-menu-rebuild menu)
|
|
(if was-active (debug-menu-context-send-msg context (debug-menu-msg activate) (debug-menu-dest activation))))
|
|
menu)
|
|
|
|
(defun debug-menu-func-decode ((value object))
|
|
"Get a function. The input can be a symbol or a function. Otherwise it will give you the nothing function."
|
|
(let ((value-type (rtype-of value)))
|
|
(the-as function
|
|
(cond
|
|
((or (= value-type symbol) (= value-type type)) (the-as symbol (-> (the-as symbol value) value)))
|
|
((= value-type function) (the-as symbol value))
|
|
(else (the-as symbol nothing))))))
|
|
|
|
(defun-recursive debug-menu-make-from-template debug-menu-node ((context debug-menu-context) (template pair))
|
|
"Recursively build menus and items from a static template. Menu entries contain child templates;
|
|
flag and function entries decode callbacks; variable entries select integer, fixed-point,
|
|
hexadecimal, floating-point, or scaled floating-point setup."
|
|
(local-vars (result basic))
|
|
(when (or (not template) (null? template))
|
|
(set! result #f)
|
|
(goto cfg-41))
|
|
(let ((kind (car template))
|
|
(name (the-as string (car (cdr template)))))
|
|
(cond
|
|
((= kind 'menu)
|
|
(let ((submenu (new 'debug 'debug-menu context name)))
|
|
(set! result (new 'debug 'debug-menu-item-submenu name submenu))
|
|
(let* ((children (cdr (cdr template)))
|
|
(child-template (car children)))
|
|
(while (not (null? children))
|
|
(let ((child (debug-menu-make-from-template context (the-as pair child-template)))) (if child (debug-menu-append-item submenu child)))
|
|
(set! children (cdr children))
|
|
(set! child-template (car children))))))
|
|
((= kind 'main-menu)
|
|
(set! result (new 'debug 'debug-menu context name))
|
|
(let* ((children (cdr (cdr template)))
|
|
(child-template (car children)))
|
|
(while (not (null? children))
|
|
(let ((child (debug-menu-make-from-template context (the-as pair child-template))))
|
|
(if child (debug-menu-append-item (the-as debug-menu result) child)))
|
|
(set! children (cdr children))
|
|
(set! child-template (car children))))
|
|
(debug-menu-context-set-root-menu context (the-as debug-menu result)))
|
|
(else
|
|
(set! result
|
|
(cond
|
|
((= kind 'flag)
|
|
(new 'debug
|
|
'debug-menu-item-flag
|
|
name
|
|
(car (cdr (cdr template)))
|
|
(the-as (function object debug-menu-msg object) (debug-menu-func-decode (car (cdr (cdr (cdr template))))))))
|
|
((or (= kind 0) (= kind 'function))
|
|
(new 'debug
|
|
'debug-menu-item-function
|
|
name
|
|
(car (cdr (cdr template)))
|
|
(the-as (function object object) (debug-menu-func-decode (car (cdr (cdr (cdr template))))))))
|
|
((= kind 'var)
|
|
(new 'debug 'debug-menu-item-var name (the-as int (car (cdr (cdr template)))) (the-as int (car (cdr (cdr (cdr template)))))))
|
|
((or (= kind 'int-var) (= kind 'int-var-gat1) (= kind 'hex-var))
|
|
(set! result (new 'debug 'debug-menu-item-var name (the-as int (car (cdr (cdr template)))) (the-as int (ref template 4))))
|
|
(debug-menu-item-var-make-int (the-as debug-menu-item-var result)
|
|
(the-as (function int debug-menu-msg int int int) (debug-menu-func-decode (car (cdr (cdr (cdr template))))))
|
|
(/ (the-as int (ref template 5)) 8)
|
|
(the-as symbol (ref template 6))
|
|
(/ (the-as int (ref template 7)) 8)
|
|
(/ (the-as int (ref template 8)) 8)
|
|
(= kind 'hex-var))
|
|
;; PC: GAT1 integer values are stored in hundredths but displayed with one
|
|
;; decimal digit; ordinary integer and hexadecimal entries stay integral.
|
|
(set! (-> (the-as debug-menu-item-var result) ifloat-p) (= kind 'int-var-gat1)) ;;#t)
|
|
result)
|
|
((= kind 'float-var)
|
|
(set! result (new 'debug 'debug-menu-item-var name (the-as int (car (cdr (cdr template)))) (the-as int (ref template 4))))
|
|
(debug-menu-item-var-make-float (the-as debug-menu-item-var result)
|
|
(the-as (function int debug-menu-msg float float float) (debug-menu-func-decode (car (cdr (cdr (cdr template))))))
|
|
(the float (/ (the-as int (ref template 5)) 8))
|
|
(the-as symbol (ref template 6))
|
|
(the float (/ (the-as int (ref template 7)) 8))
|
|
(the float (/ (the-as int (ref template 8)) 8))
|
|
(/ (the-as int (ref template 9)) 8))
|
|
result)
|
|
((= kind 'float-fixed-var)
|
|
(set! result (new 'debug 'debug-menu-item-var name (the-as int (car (cdr (cdr template)))) (the-as int (ref template 4))))
|
|
(debug-menu-item-var-make-float (the-as debug-menu-item-var result)
|
|
(the-as (function int debug-menu-msg float float float) (debug-menu-func-decode (car (cdr (cdr (cdr template))))))
|
|
(* 0.001 (the float (/ (the-as int (ref template 5)) 8)))
|
|
(the-as symbol (ref template 6))
|
|
(* 0.001 (the float (/ (the-as int (ref template 7)) 8)))
|
|
(* 0.001 (the float (/ (the-as int (ref template 8)) 8)))
|
|
(/ (the-as int (ref template 9)) 8))
|
|
result)
|
|
(else #f))))))
|
|
(label cfg-41)
|
|
(the-as debug-menu-node result))
|
|
|
|
(defun debug-menu-find-from-template ((context debug-menu-context) (path pair))
|
|
"Find a debug-menu that was added by a template. This could be used to modify it after,
|
|
for example to add in options that might not be known at compile-time."
|
|
(let ((node (the-as object (-> context root-menu))))
|
|
(while (begin
|
|
(label cfg-17)
|
|
(and node (type-type? (-> (the-as debug-menu-node node) type) debug-menu) (not (null? path))))
|
|
(let ((items (-> (the-as debug-menu node) items))
|
|
(path-name (car path)))
|
|
(set! path (cdr path))
|
|
(let ((item (car items)))
|
|
(while (not (null? items))
|
|
(when (string= (the-as string path-name) (-> (the-as debug-menu-item item) name))
|
|
(if (type-type? (rtype-of item) debug-menu-item-submenu)
|
|
(set! node (-> (the-as debug-menu-item-submenu item) submenu))
|
|
(set! node item))
|
|
(goto cfg-17))
|
|
(set! items (cdr items))
|
|
(set! item (car items)))))
|
|
(set! node #f)
|
|
(goto cfg-24))
|
|
(label cfg-24)
|
|
(the-as debug-menu node)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; rendering
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun debug-menu-item-submenu-render ((item debug-menu-item-submenu) (x int) (y int) (submenus int) (selected symbol))
|
|
"Draw the text for a submenu. Like Render...
|
|
The submenus parameter is the number of _open_ menus below the one containing this item"
|
|
(let ((font (-> item parent context font)))
|
|
(set-origin! font x y)
|
|
(set! (-> font color)
|
|
(cond
|
|
((zero? submenus) (font-color menu)) ;; in the active menu, white
|
|
(selected (font-color menu-selected-parent)) ;; a parent, but selected
|
|
(else (font-color menu-parent)) ;; a parent, but not selected
|
|
))
|
|
(with-dma-buffer-add-bucket ((dma-buf (-> (current-frame) debug-buf)) (bucket-id debug-no-zbuf))
|
|
(draw-string-adv (-> item name) dma-buf font)
|
|
(draw-string-adv "..." dma-buf font)))
|
|
item)
|
|
|
|
(defun debug-menu-item-function-render ((item debug-menu-item-function) (x int) (y int) (submenus int) (selected symbol))
|
|
"Draw the text for a function entry. Also updates the timer for the highlight."
|
|
(let ((font (-> item parent context font)))
|
|
(set-origin! font x y)
|
|
(set! (-> font color)
|
|
(cond
|
|
((> (-> item hilite-timer) 0)
|
|
;; if the hilite is >0, we ran the function successfully, so we hilite in blue for a bit
|
|
(1-! (-> item hilite-timer))
|
|
(font-color menu-selected))
|
|
((< (-> item hilite-timer) 0)
|
|
;; if we're negative, it failed, so hilite in red
|
|
(1+! (-> item hilite-timer))
|
|
(font-color menu-func-bad))
|
|
((nonzero? submenus)
|
|
;; in a parent menu
|
|
(font-color menu-parent))
|
|
(else
|
|
;; option in the active menu.
|
|
(font-color menu))))
|
|
(with-dma-buffer-add-bucket ((dma-buf (-> (current-frame) debug-buf)) (bucket-id debug-no-zbuf))
|
|
(draw-string (-> item name) dma-buf font)))
|
|
item)
|
|
|
|
(defun debug-menu-item-flag-render ((item debug-menu-item-flag) (x int) (y int) (submenus int) (selected symbol))
|
|
"Draw the text for a flag."
|
|
(let ((font (-> item parent context font)))
|
|
(set-origin! font x y)
|
|
(set! (-> font color)
|
|
(cond
|
|
((= (-> item is-on) 'invalid)
|
|
(font-color menu-invalid) ;; can't use this one.
|
|
)
|
|
((-> item is-on)
|
|
(if (zero? submenus)
|
|
(font-color menu-flag-on) ;; on, and in active menu
|
|
(font-color menu-flag-on-parent) ;; on, and in parent menu
|
|
))
|
|
((zero? submenus)
|
|
(font-color menu-flag-off) ;; off, and in active menu
|
|
)
|
|
(else
|
|
(font-color menu-flag-off-parent) ;; off, and in parent menu
|
|
)))
|
|
(with-dma-buffer-add-bucket ((dma-buf (-> (current-frame) debug-buf)) (bucket-id debug-no-zbuf))
|
|
(draw-string (-> item name) dma-buf font)))
|
|
item)
|
|
|
|
(defun debug-menu-item-var-render ((item debug-menu-item-var) (x int) (y int) (submenus int) (selected symbol))
|
|
"Draw the text for a variable"
|
|
(let ((font (-> item parent context font)))
|
|
(set-origin! font x y)
|
|
(set! (-> font color)
|
|
(cond
|
|
((zero? submenus)
|
|
(if (-> item grabbed-joypad-p)
|
|
(font-color menu-selected) ;; active menu, using joypad
|
|
(font-color menu) ;; active menu, but not grabbed
|
|
))
|
|
(selected
|
|
(font-color menu-selected-parent) ;; selected entry in a parent menu
|
|
)
|
|
(else (font-color menu-parent))))
|
|
(with-dma-buffer-add-bucket ((dma-buf (-> (current-frame) debug-buf)) (bucket-id debug-no-zbuf))
|
|
(draw-string-adv (-> item name) dma-buf font)
|
|
(draw-string-adv ":" dma-buf font)
|
|
(cond
|
|
((>= (-> item show-len) (length (-> item display-str)))
|
|
;; enough room to just draw the whole thing
|
|
(draw-string (-> item display-str) dma-buf font))
|
|
(else
|
|
;; not enough room. normally just draw ...
|
|
(draw-string "..." dma-buf font)
|
|
;; display the whole thing if: we're selected and there are no submenus.
|
|
(set! selected (and (zero? submenus) selected))
|
|
(when selected
|
|
(set-origin! font 20 204)
|
|
(draw-string-adv (-> item name) dma-buf font)
|
|
(draw-string-adv ":" dma-buf font)
|
|
(draw-string (-> item display-str) dma-buf font))))))
|
|
item)
|
|
|
|
(defun debug-menu-item-render ((item debug-menu-item) (x int) (y int) (submenus int) (selected symbol))
|
|
"Draw an item. This feels like it should have been a method..."
|
|
;; do a refresh, if it's time.
|
|
(when (> (-> item refresh-delay) 0)
|
|
(+! (-> item refresh-ctr) -1)
|
|
(when (<= (-> item refresh-ctr) 0)
|
|
(set! (-> item refresh-ctr) (-> item refresh-delay))
|
|
(debug-menu-item-send-msg item (debug-menu-msg update))))
|
|
;; call the appropriate render function.
|
|
(cond
|
|
((= (-> item type) debug-menu-item-submenu)
|
|
(debug-menu-item-submenu-render (the-as debug-menu-item-submenu item) x y submenus selected))
|
|
((= (-> item type) debug-menu-item-function)
|
|
(debug-menu-item-function-render (the-as debug-menu-item-function item) x y submenus selected))
|
|
((= (-> item type) debug-menu-item-flag)
|
|
(debug-menu-item-flag-render (the-as debug-menu-item-flag item) x y submenus selected))
|
|
((= (-> item type) debug-menu-item-var)
|
|
(debug-menu-item-var-render (the-as debug-menu-item-var item) x y submenus selected))
|
|
(else (format 0 "ERROR: Found unknown item type!~%")))
|
|
item)
|
|
|
|
(defun debug-menu-render ((menu debug-menu) (x-pos int) (y-pos int) (selected debug-menu-node) (submenus int))
|
|
"Render a menu."
|
|
;; draw the background
|
|
(let ((selection-index 0))
|
|
(let* ((items (-> menu items))
|
|
(item (car items)))
|
|
(while (not (null? items))
|
|
(if (= item selected) (goto cfg-7))
|
|
(+! selection-index 1)
|
|
(set! items (cdr items))
|
|
(set! item (car items))))
|
|
(label cfg-7)
|
|
(if (< 16 selection-index) (set! y-pos (- y-pos (* (+ selection-index -16) 8)))))
|
|
(with-dma-buffer-add-bucket ((dma-buf (-> (current-frame) debug-buf)) (bucket-id debug-no-zbuf))
|
|
;; og:preserve-this fixed for widescreen
|
|
(draw-sprite2d-xy dma-buf
|
|
(correct-x-int x-pos)
|
|
y-pos
|
|
(correct-x-int (-> menu pix-width))
|
|
(-> menu pix-height)
|
|
(static-rgba #x00 #x00 #x00 #x40)))
|
|
;; draw each item
|
|
(let* ((item-x (+ x-pos 3))
|
|
(item-y (+ y-pos 3))
|
|
(items (-> menu items))
|
|
(item (car items)))
|
|
(while (not (null? items))
|
|
;; draw > on the selected object
|
|
(when (= item selected)
|
|
;; dim it if it's in a parent menu.
|
|
(set! (-> menu context font color) (if (nonzero? submenus) (font-color menu-parent) (font-color menu)))
|
|
(set-origin! (-> menu context font) item-x item-y)
|
|
(with-dma-buffer-add-bucket ((dma-buf (-> (current-frame) debug-buf)) (bucket-id debug-no-zbuf))
|
|
(draw-string ">" dma-buf (-> menu context font))))
|
|
;; actually draw the item.
|
|
;; og:preserve-this do not render if text is out of bounds...
|
|
(when (and (< -20 item-y) (> 256 item-y))
|
|
(debug-menu-item-render (the-as debug-menu-item item) (+ item-x 12) item-y submenus (= item selected)))
|
|
(+! item-y 8)
|
|
(set! items (cdr items))
|
|
(set! item (car items))))
|
|
menu)
|
|
|
|
(defun debug-menu-context-render ((context debug-menu-context))
|
|
"Render all menus"
|
|
(let ((x-pos 6))
|
|
;; loop down the stack of menus
|
|
(dotimes (stack-idx (-> context sel-length))
|
|
;; the menu being drawn at this depth
|
|
(let ((menu (-> context sel-menu stack-idx)))
|
|
;; the thing that's selected at this depth.
|
|
(let ((selection (-> menu selected-item)))
|
|
(debug-menu-render menu x-pos 28 selection (+ (- -1 stack-idx) (-> context sel-length))))
|
|
(set! x-pos (+ x-pos 3 (-> menu pix-width))))))
|
|
context)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; navigate
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun debug-menu-context-select-next-or-prev-item ((context debug-menu-context) (direction int))
|
|
"Go up or down 1 in the currently open thing. The sign of arg1 determines direction"
|
|
(local-vars (next-item object))
|
|
;; search for the currently selected thing.
|
|
(let ((menu (-> context sel-menu (+ (-> context sel-length) -1))))
|
|
(let ((selected (-> menu selected-item))
|
|
(previous-cell '()) ;; thing before selection
|
|
(selected-cell '()) ;; current selection
|
|
)
|
|
(let ((items (-> menu items)))
|
|
(while (not (null? items))
|
|
(when (= (car items) selected)
|
|
(set! selected-cell items)
|
|
(goto cfg-7))
|
|
(set! previous-cell items)
|
|
(set! items (cdr items))))
|
|
(label cfg-7)
|
|
(when (null? selected-cell)
|
|
(format 0 "ERROR: Couldn't find selected item in menu.~%")
|
|
(set! context context)
|
|
(goto cfg-19))
|
|
(cond
|
|
((>= direction 0) (if (null? (cdr selected-cell)) (set! next-item (car (-> menu items))) (set! next-item (car (cdr selected-cell)))))
|
|
((null? previous-cell) (set! next-item (car (last (-> menu items)))))
|
|
(else (set! next-item (car previous-cell)))))
|
|
(set! (-> menu selected-item) (the-as debug-menu-item next-item)))
|
|
(label cfg-19)
|
|
context)
|
|
|
|
(defun debug-menu-context-select-new-item ((context debug-menu-context) (offset int))
|
|
"Move the current selection by offset entries, shortening the move at either end and wrapping
|
|
only when the selection already starts on the first or last entry."
|
|
(let* ((menu (-> context sel-menu (+ (-> context sel-length) -1)))
|
|
(selected (-> menu selected-item))
|
|
(item-count 0)
|
|
(selected-index -1))
|
|
(let ((items (-> menu items)))
|
|
(while (not (null? items))
|
|
(if (= (car items) selected) (set! selected-index item-count))
|
|
(set! items (cdr items))
|
|
(+! item-count 1)))
|
|
(when (= selected-index -1)
|
|
(format 0 "ERROR: Couldn't find selected item in menu.~%")
|
|
(set! context context)
|
|
(goto cfg-25))
|
|
(cond
|
|
((>= offset 0)
|
|
(cond
|
|
((= selected-index (+ item-count -1)) (set! offset 1))
|
|
((>= (+ selected-index offset) item-count) (set! offset (+ (- -1 selected-index) item-count))))
|
|
(dotimes (i offset)
|
|
(debug-menu-context-select-next-or-prev-item context 1)))
|
|
(else
|
|
(cond
|
|
((zero? selected-index) (set! offset -1))
|
|
((< (+ selected-index offset) 0) (set! offset (- selected-index))))
|
|
(dotimes (i (- offset))
|
|
(debug-menu-context-select-next-or-prev-item context -1)))))
|
|
(label cfg-25)
|
|
context)
|
|
|
|
(defun debug-menu-context-open-submenu ((context debug-menu-context) (submenu debug-menu))
|
|
"Push a nonempty submenu onto the selection stack, select its first item when needed, and
|
|
activate its entries. Refuse stacks deeper than eight menus."
|
|
(let ((depth (-> context sel-length)))
|
|
(when (>= depth 8)
|
|
(format 0 "ERROR: Trying to exceed maximum menu depth!")
|
|
(return submenu))
|
|
(when (null? (-> submenu items))
|
|
(format 0 "ERROR: Submenu has no items!")
|
|
(return submenu))
|
|
(set! (-> context sel-menu depth) submenu)
|
|
(if (not (-> submenu selected-item)) (set! (-> submenu selected-item) (the-as debug-menu-item (-> submenu items car))))
|
|
(set! (-> context sel-length) (+ depth 1)))
|
|
(debug-menu-context-send-msg context (debug-menu-msg activate) (debug-menu-dest current-selection)))
|
|
|
|
(defun debug-menu-context-close-submenu ((context debug-menu-context))
|
|
"Deactivate the current menu, then pop it from the open-menu stack when it is below the root."
|
|
(debug-menu-context-send-msg context (debug-menu-msg deactivate) (debug-menu-dest current-selection))
|
|
(if (< 1 (-> context sel-length)) (+! (-> context sel-length) -1))
|
|
context)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; message handling
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; items each have their own handlers for messages.
|
|
|
|
(defun debug-menu-item-submenu-msg ((item debug-menu-item-submenu) (message debug-menu-msg))
|
|
"Open the item's submenu when it receives a press message."
|
|
;; on press, open the submenu
|
|
(when (= message (debug-menu-msg press))
|
|
(let ((context (-> item parent context))) (debug-menu-context-open-submenu context (-> item submenu))))
|
|
item)
|
|
|
|
(defun debug-menu-item-function-msg ((item debug-menu-item-function) (message debug-menu-msg))
|
|
"Invoke the item's callback on press and set a short blue or red highlight according to its
|
|
result. Clear the highlight when the item is deactivated."
|
|
(cond
|
|
((= message (debug-menu-msg press))
|
|
;; on press, call the function!
|
|
(cond
|
|
((-> item activate-func)
|
|
(if ((-> item activate-func) (-> item id)) (set! (-> item hilite-timer) 6) (set! (-> item hilite-timer) -6)))
|
|
(else (set! (-> item hilite-timer) -6))))
|
|
((= message (debug-menu-msg deactivate))
|
|
;; on deactivate, clear hilite.
|
|
(set! (-> item hilite-timer) 0)
|
|
0))
|
|
item)
|
|
|
|
(defun debug-menu-item-flag-msg ((item debug-menu-item-flag) (message debug-menu-msg))
|
|
"Toggle the flag callback on press, query it on update or activation, and refresh the open menus
|
|
after a change."
|
|
(cond
|
|
((= message (debug-menu-msg press))
|
|
;; on press, call the function.
|
|
(if (-> item activate-func) (set! (-> item is-on) ((-> item activate-func) (-> item id) (debug-menu-msg press))))
|
|
;; also update all open menus.
|
|
(let ((context (-> item parent context)))
|
|
(debug-menu-context-send-msg context (debug-menu-msg update) (debug-menu-dest open-menus))))
|
|
((or (= message (debug-menu-msg update)) (= message (debug-menu-msg activate)))
|
|
;; just query the value.
|
|
(if (-> item activate-func) (set! (-> item is-on) ((-> item activate-func) (-> item id) (debug-menu-msg update))))
|
|
;; update the refresh counter.
|
|
(set! (-> item refresh-ctr) (-> item refresh-delay))))
|
|
item)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; joypad handling
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun debug-menu-item-var-joypad-handler ((item debug-menu-item-var))
|
|
"Edit the grabbed variable from the directional pad. Begin with the configured step, repeat after
|
|
a short delay, and double the step every 30 held frames up to the numeric cap. Releasing X
|
|
commits the value; pressing Circle while releasing restores the saved value."
|
|
(cond
|
|
((not (cpad-hold? 0 x))
|
|
(let ((context (-> item parent context))) (debug-menu-context-release-joypad context))
|
|
(set! (-> item grabbed-joypad-p) #f)
|
|
(when (cpad-pressed? 0 circle)
|
|
(cond
|
|
((-> item float-p)
|
|
(if (-> item factivate-func)
|
|
(set! (-> item fval) ((-> item factivate-func) (-> item id) (debug-menu-msg press) (-> item fundo-val) (-> item fval)))))
|
|
(else
|
|
(if (-> item factivate-func)
|
|
(set! (-> item fval)
|
|
(the-as float
|
|
((the-as (function int int int int int) (-> item factivate-func))
|
|
(-> item id)
|
|
4
|
|
(the-as int (-> item fundo-val))
|
|
(the-as int (-> item fval))))))))
|
|
(debug-menu-item-var-update-display-str item))
|
|
(let ((context (-> item parent context)))
|
|
(debug-menu-context-send-msg context (debug-menu-msg update) (debug-menu-dest open-menus))))
|
|
((or (cpad-hold? 0 right) (cpad-hold? 0 left) (cpad-hold? 0 down) (cpad-hold? 0 up))
|
|
(let ((direction (cond
|
|
((cpad-hold? 0 right) 10)
|
|
((cpad-hold? 0 up) 1)
|
|
((cpad-hold? 0 down) -1)
|
|
(else -10))))
|
|
(when (!= direction (-> item inc-dir))
|
|
(set! (-> item inc-dir) direction)
|
|
(set! (-> item inc-delay) 15)
|
|
(set! (-> item inc-delay-ctr) 0)
|
|
(set! (-> item step-delay-ctr) 30)
|
|
(set! (-> item fstep) (-> item fstart-inc))
|
|
(set! (-> item fstep) (-> item fstart-inc))))
|
|
(cond
|
|
((<= (-> item inc-delay-ctr) 0)
|
|
(if (> (-> item inc-delay) 0) (+! (-> item inc-delay) -1))
|
|
(when (zero? (-> item inc-delay))
|
|
(cond
|
|
((<= (-> item step-delay-ctr) 0)
|
|
(set! (-> item step-delay-ctr) 30)
|
|
(cond
|
|
((-> item float-p) (if (< (-> item fstep) 10000000.0) (set! (-> item fstep) (* 2.0 (-> item fstep)))))
|
|
(else
|
|
(if (< (the-as int (-> item fstep)) #x989680) (set! (-> item fstep) (the-as float (* (the-as int (-> item fstep)) 2)))))))
|
|
(else (+! (-> item step-delay-ctr) -1))))
|
|
(set! (-> item inc-delay-ctr) (-> item inc-delay))
|
|
(cond
|
|
((-> item float-p)
|
|
(when (-> item factivate-func)
|
|
(let ((new-float-value (+ (-> item fval) (* (the float (-> item inc-dir)) (-> item fstep)))))
|
|
(if (-> item range-p) (set! new-float-value (fmin (fmax new-float-value (-> item frange-min)) (-> item frange-max))))
|
|
(set! (-> item fval) ((-> item factivate-func) (-> item id) (debug-menu-msg press) new-float-value (-> item fval))))))
|
|
(else
|
|
(when (-> item factivate-func)
|
|
(let ((new-int-value (+ (the-as int (-> item fval)) (* (-> item inc-dir) (the-as int (-> item fstep))))))
|
|
(if (-> item range-p) (set! new-int-value (min (max new-int-value (the-as int (-> item frange-min))) (the-as int (-> item frange-max)))))
|
|
(set! (-> item fval)
|
|
(the-as float
|
|
((the-as (function int int int int int) (-> item factivate-func)) (-> item id) 4 new-int-value (the-as int (-> item fval)))))))))
|
|
(debug-menu-item-var-update-display-str item)
|
|
(let ((context (-> item parent context)))
|
|
(debug-menu-context-send-msg context (debug-menu-msg update) (debug-menu-dest current-selection))))
|
|
(else (+! (-> item inc-delay-ctr) -1))))
|
|
(else (set! (-> item inc-dir) 0) 0))
|
|
item)
|
|
|
|
(defun debug-menu-item-var-msg ((item debug-menu-item-var) (message debug-menu-msg))
|
|
"Begin variable editing on press, save the undo value, release the joypad on deactivation, and
|
|
query the callback on update or activation."
|
|
(cond
|
|
((= message (debug-menu-msg deactivate))
|
|
(when (-> item grabbed-joypad-p)
|
|
(let ((context (-> item parent context))) (debug-menu-context-release-joypad context))
|
|
(set! (-> item grabbed-joypad-p) #f)))
|
|
((= message (debug-menu-msg press))
|
|
(when (not (-> item grabbed-joypad-p))
|
|
(let ((context (-> item parent context)))
|
|
(when (debug-menu-context-grab-joypad context item (the-as (function basic none) debug-menu-item-var-joypad-handler))
|
|
(set! (-> item grabbed-joypad-p) #t)
|
|
(set! (-> item fundo-val) (-> item fval))
|
|
(set! (-> item fundo-val) (-> item fval))
|
|
(set! (-> item inc-dir) 0)
|
|
0))))
|
|
((or (= message (debug-menu-msg update)) (= message (debug-menu-msg activate)))
|
|
(cond
|
|
((-> item float-p)
|
|
(if (-> item factivate-func)
|
|
(set! (-> item fval) ((-> item factivate-func) (-> item id) (debug-menu-msg update) (-> item fval) (-> item fval)))))
|
|
(else
|
|
(if (-> item factivate-func)
|
|
(set! (-> item fval)
|
|
(the-as float
|
|
((the-as (function int int int int int) (-> item factivate-func))
|
|
(-> item id)
|
|
3
|
|
(the-as int (-> item fval))
|
|
(the-as int (-> item fval))))))))
|
|
(debug-menu-item-var-update-display-str item)
|
|
(set! (-> item refresh-ctr) (-> item refresh-delay))))
|
|
item)
|
|
|
|
(defun debug-menu-item-send-msg ((item debug-menu-item) (message debug-menu-msg))
|
|
"Call the appropriate message handler for the given item."
|
|
(cond
|
|
((= (-> item type) debug-menu-item-submenu) (debug-menu-item-submenu-msg (the-as debug-menu-item-submenu item) message))
|
|
((= (-> item type) debug-menu-item-function) (debug-menu-item-function-msg (the-as debug-menu-item-function item) message))
|
|
((= (-> item type) debug-menu-item-flag) (debug-menu-item-flag-msg (the-as debug-menu-item-flag item) message))
|
|
((= (-> item type) debug-menu-item-var) (debug-menu-item-var-msg (the-as debug-menu-item-var item) message))
|
|
(else (format 0 "ERROR: Found unknown item type!~%")))
|
|
item)
|
|
|
|
(defun-recursive debug-menu-send-msg debug-menu ((menu debug-menu) (message debug-menu-msg) (recursive symbol))
|
|
"Send to all items in menu. Arg2 picks if we are recursive or not."
|
|
(let* ((items (-> menu items))
|
|
(item (car items)))
|
|
(while (not (null? items))
|
|
(debug-menu-item-send-msg (the-as debug-menu-item item) message)
|
|
(if (and recursive (= (-> (the-as debug-menu-item item) type) debug-menu-item-submenu))
|
|
(debug-menu-send-msg (-> (the-as debug-menu-item-submenu item) submenu) message #t))
|
|
(set! items (cdr items))
|
|
(set! item (car items))))
|
|
menu)
|
|
|
|
(defun debug-menu-context-send-msg ((context debug-menu-context) (message debug-menu-msg) (destination debug-menu-dest))
|
|
"Send the arg1 message to the given place."
|
|
(cond
|
|
((= destination (debug-menu-dest root))
|
|
;; sent to root, recursively. This will hit the whole menu.
|
|
(debug-menu-send-msg (-> context root-menu) message #t))
|
|
((= destination (debug-menu-dest open-menus))
|
|
;; only send to open things
|
|
(when (-> context is-active) ;; only if context is open
|
|
(dotimes (i (-> context sel-length)) ;; go through stack
|
|
(let ((menu (-> context sel-menu i)))
|
|
;; send, not recursive
|
|
(debug-menu-send-msg menu message #f)))))
|
|
((= destination (debug-menu-dest current-selection))
|
|
(when (-> context is-active) ;; context open
|
|
(if (nonzero? (-> context sel-length)) ;; something in the stack
|
|
(debug-menu-send-msg (-> context sel-menu (+ (-> context sel-length) -1)) message #f) ;; send to that.
|
|
)))
|
|
((= destination (debug-menu-dest activation))
|
|
;; this is a special case for when we want to activate or deactivate something.
|
|
(cond
|
|
((= message (debug-menu-msg activate))
|
|
(when (not (-> context is-active))
|
|
(set! (-> context is-active) #t)
|
|
(debug-menu-context-send-msg context (debug-menu-msg activate) (debug-menu-dest open-menus))))
|
|
((= message (debug-menu-msg deactivate))
|
|
(when (-> context is-active)
|
|
(debug-menu-context-send-msg context (debug-menu-msg deactivate) (debug-menu-dest open-menus))
|
|
(set! (-> context is-active) #f))))))
|
|
context)
|
|
|
|
(defun debug-menu-context-activate-selection ((context debug-menu-context))
|
|
"Press on the selected thing. Note that we named this enum press, not activate."
|
|
(let ((item (-> context sel-menu (+ (-> context sel-length) -1) selected-item)))
|
|
(debug-menu-item-send-msg item (debug-menu-msg press)))
|
|
context)
|
|
|
|
(defun debug-menus-default-joypad-func ((context debug-menu-context))
|
|
"Control the menu from the joystick"
|
|
(cond
|
|
((cpad-pressed? 0 square)
|
|
(cond
|
|
((< 1 (-> context sel-length)) (debug-menu-context-close-submenu context))
|
|
(else)))
|
|
((cpad-pressed? 0 x) (debug-menu-context-activate-selection context))
|
|
((cpad-pressed? 0 up) (debug-menu-context-select-new-item context -1))
|
|
((cpad-pressed? 0 down) (debug-menu-context-select-new-item context 1))
|
|
((cpad-pressed? 0 left) (debug-menu-context-select-new-item context -5))
|
|
((cpad-pressed? 0 right) (debug-menu-context-select-new-item context 5)))
|
|
context)
|
|
|
|
(defun debug-menus-active ((context debug-menu-context))
|
|
"Run the menu context"
|
|
(when (not (-> context is-hidden))
|
|
;; grab inputs
|
|
(if (-> context joypad-func) ((-> context joypad-func) (-> context joypad-item)) (debug-menus-default-joypad-func context))
|
|
;; render
|
|
(debug-menu-context-render context))
|
|
context)
|
|
|
|
(defun debug-menus-handler ((context debug-menu-context))
|
|
"Update and draw the menu context while it is active."
|
|
(if (-> context is-active) (debug-menus-active context))
|
|
context)
|