;;-*-Lisp-*- (in-package goal) ;; name: menu.gc ;; name in dgo: menu ;; dgos: GAME, ENGINE ;; 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. ;; this file is debug only (declare-file (debug)) (when *debug-segment* (declare-type debug-menu basic) (declare-type debug-menu-item basic) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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 :offset-assert 4) ;; should we draw? (sel-length int32 :offset-assert 8) ;; depth of open menus (sel-menu debug-menu 8 :offset-assert 12) ;; at each level, what is selected? (root-menu debug-menu :offset-assert 44) ;; the top level menu (joypad-func (function basic none) :offset-assert 48) ;; if not, #f, callback for getting joystick inputs (joypad-item basic :offset-assert 52) ;; object passed as arg to joypad-func (font font-context :offset-assert 56) ;; font rendering settings (is-hidden symbol :offset-assert 60) ;; set to #t to temporarily hide. ) :method-count-assert 9 :size-assert #x40 :flag-assert #x900000040 (:methods (new (symbol type) _type_ 0) ) ) (defmethod new debug-menu-context ((allocation symbol) (type-to-make type)) "Create a new debug-menu-context" (let ((gp-0 (object-new allocation type-to-make (the-as int (-> type-to-make size))))) (set! (-> gp-0 is-active) #f) (set! (-> gp-0 is-hidden) #f) (set! (-> gp-0 sel-length) 0) (set! (-> gp-0 root-menu) #f) (set! (-> gp-0 joypad-func) #f) (set! (-> gp-0 joypad-item) #f) (set! (-> gp-0 font) (new 'debug 'font-context *font-default-matrix* 0 0 0.0 (font-color default) (font-flags shadow kerning pc-hack))) gp-0 ) ) ;; 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 :offset-assert 4) ;; if it's an item, this is its name. (parent debug-menu :offset-assert 8) ;; note: can actually be an item in rare cases (refresh-delay int32 :offset-assert 12) ;; how many frames to wait before updating (refresh-ctr int32 :offset-assert 16) ;; how many frames since we updated. ) :method-count-assert 9 :size-assert #x14 :flag-assert #x900000014 ) (defmethod print debug-menu-node ((obj debug-menu-node)) (format #t "#<~A ~A @ #x~X>" (-> obj type) (-> obj name) obj) obj ) ;; Parent type for a menu (list of things) (deftype debug-menu (debug-menu-node) ((context debug-menu-context :offset-assert 20) (selected-item debug-menu-item :offset-assert 24) (pix-width int32 :offset-assert 28) ;; background draw size (pix-height int32 :offset-assert 32) (items pair :offset-assert 36) ;; children. ) :method-count-assert 9 :size-assert #x28 :flag-assert #x900000028 (:methods (new (symbol type debug-menu-context string) _type_ 0) ) ) (defmethod new debug-menu ((allocation symbol) (type-to-make type) (ctxt debug-menu-context) (name string)) "Create a new debug-menu" (let ((v0-0 (object-new allocation type-to-make (the-as int (-> type-to-make size))))) (set! (-> v0-0 context) ctxt) (set! (-> v0-0 name) name) (set! (-> v0-0 parent) #f) (set! (-> v0-0 selected-item) #f) (set! (-> v0-0 items) '()) v0-0 ) ) ;; Parent type for an item (an individual, selectable entry within a menu) (deftype debug-menu-item (debug-menu-node) ((id int32 :offset-assert 20) ) :method-count-assert 9 :size-assert #x18 :flag-assert #x900000018 ) ;; An item that opens a submenu. (deftype debug-menu-item-submenu (debug-menu-item) ((submenu debug-menu :offset-assert 24) ) :method-count-assert 9 :size-assert #x1c :flag-assert #x90000001c (:methods (new (symbol type string debug-menu) _type_ 0) ) ) (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 ((v0-0 (object-new allocation type-to-make (the-as int (-> type-to-make size))))) (set! (-> v0-0 name) name) (set! (-> v0-0 parent) #f) (set! (-> v0-0 refresh-delay) 0) (set! (-> v0-0 refresh-ctr) (-> v0-0 refresh-delay)) (set! (-> v0-0 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! (-> v0-0 submenu parent) (the-as debug-menu v0-0)) v0-0 ) ) ;;;;;;;;;;;;;;;;;;;;;;;; ;; 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) :offset-assert 24) (hilite-timer int8 :offset-assert 28) ;; how much longer to stay highlighted for. ) :method-count-assert 9 :size-assert #x1d :flag-assert #x90000001d (:methods (new (symbol type string object (function object object)) _type_ 0) ) ) (defmethod new debug-menu-item-function ((allocation symbol) (type-to-make type) (name string) id (func (function object object))) "Create an item for a function." (let ((obj (object-new allocation type-to-make (the-as int (-> type-to-make size))))) (set! (-> obj name) name) (set! (-> obj parent) #f) (set! (-> obj refresh-delay) 0) (set! (-> obj refresh-ctr) (-> obj refresh-delay)) (set! (-> obj id) (the-as int id)) (set! (-> obj activate-func) func) (set! (-> obj hilite-timer) 0) obj ) ) ;; An item with on/off state. (deftype debug-menu-item-flag (debug-menu-item) ((activate-func (function object debug-menu-msg object) :offset-assert 24) (is-on object :offset-assert 28) ) :method-count-assert 9 :size-assert #x20 :flag-assert #x900000020 (:methods (new (symbol type string object (function object debug-menu-msg object)) _type_ 0) ) ) (defmethod new debug-menu-item-flag ((allocation symbol) (type-to-make type) (name string) id (func (function object debug-menu-msg object))) "Create a new item for a flag. By default, the refresh-delay is set to 23." (let ((v0-0 (object-new allocation type-to-make (the-as int (-> type-to-make size))))) (set! (-> v0-0 name) name) (set! (-> v0-0 parent) #f) (set! (-> v0-0 refresh-delay) 23) (set! (-> v0-0 refresh-ctr) (-> v0-0 refresh-delay)) (set! (-> v0-0 id) (the-as int id)) (set! (-> v0-0 activate-func) func) (set! (-> v0-0 is-on) #f) v0-0 ) ) ;; An item that modifies a variable (deftype debug-menu-item-var (debug-menu-item) ((display-str string :offset-assert 24) ;; the value as a string, to draw (grabbed-joypad-p symbol :offset-assert 28) (float-p symbol :offset-assert 32) ;; treat as float (range-p symbol :offset-assert 36) (show-len int32 :offset-assert 40) (inc-delay int32 :offset-assert 44) (inc-delay-ctr int32 :offset-assert 48) (step-delay-ctr int32 :offset-assert 52) (inc-dir int32 :offset-assert 56) (fval float :offset-assert 60) (fundo-val float :offset-assert 64) (frange-min float :offset-assert 68) (frange-max float :offset-assert 72) (fstart-inc float :offset-assert 76) (fstep float :offset-assert 80) (fprecision int32 :offset-assert 84) (factivate-func (function int debug-menu-msg float float float) :offset-assert 88) (ival int32 :offset 60) (iundo-val int32 :offset 64) (irange-min int32 :offset 68) (irange-max int32 :offset 72) (istart-inc int32 :offset 76) (istep int32 :offset 80) (ihex-p symbol :offset-assert 92) ;; treat as hex (iactivate-func (function int debug-menu-msg int int int) :offset 88) (ifloat-p symbol :offset-assert 96) ;; treat as fixed point. ) :method-count-assert 9 :size-assert #x64 :flag-assert #x900000064 (:methods (new (symbol type string int int) _type_ 0) ) ) (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 ((arg0 debug-menu-item-var)) "Update display-str to the current value of the variable" (cond ((-> arg0 float-p) (format (clear (-> arg0 display-str)) "~f" (-> arg0 fval)) ) ((-> arg0 ihex-p) (format (clear (-> arg0 display-str)) "x~X" (-> arg0 fval)) ) ((-> arg0 ifloat-p) (cond ((and (< (the-as int (-> arg0 fval)) 0) (< -100 (the-as int (-> arg0 fval))) ) (let ((v1-8 (abs (the-as int (-> arg0 fval))))) (format (clear (-> arg0 display-str)) "-0.~1d" (/ (mod v1-8 100) 10)) ) ) (else (let ((v1-12 (abs (the-as int (-> arg0 fval))))) (format (clear (-> arg0 display-str)) "~2d.~1d" (/ (the-as int (-> arg0 fval)) 100) (/ (mod v1-12 100) 10)) ) ) ) ) (else (format (clear (-> arg0 display-str)) "~D" (-> arg0 fval)) ) ) arg0 ) (defun debug-menu-item-var-make-int ((item debug-menu-item-var) (callback (function int debug-menu-msg int int int)) ;; args are id, msg, value?, value? (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 ival) range-min) ) (else (set! (-> item ival) 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) ) ;; note: the return value of the callback is treated as an integer and int->float converted. This is a bug in the original code. (if callback (set! (-> item fval) (the float (the-as int (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 ((gp-0 (object-new allocation type-to-make (the-as int (-> type-to-make size))))) (let ((max-chars (/ max-width 8))) (set! (-> gp-0 name) name) (set! (-> gp-0 parent) #f) (set! (-> gp-0 refresh-delay) 31) (set! (-> gp-0 refresh-ctr) (-> gp-0 refresh-delay)) (set! (-> gp-0 id) id) (set! max-chars (if (< 3 max-chars) max-chars 3 ) ) (set! (-> gp-0 show-len) max-chars) ) (set! (-> gp-0 grabbed-joypad-p) #f) (set! (-> gp-0 ifloat-p) #f) (set! (-> gp-0 display-str) (new 'debug 'string 64 (the-as string #f))) (debug-menu-item-var-make-int gp-0 (the-as (function int debug-menu-msg int int int) #f) 1 #t 0 0 #f) gp-0 ) ) ;;;;;;;;;;;;;;;;;;;;;;;; ;; 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 ((arg0 debug-menu-item) (arg1 debug-menu)) "Determine the width, in pixels" (local-vars (v0-1 int)) 0 (cond ((= (-> arg0 type) debug-menu-item-submenu) (set! v0-1 (+ (the int (get-string-length (-> arg0 name) (-> arg1 context font))) 16)) ) ((= (-> arg0 type) debug-menu-item-var) (set! v0-1 (the int (get-string-length (-> (the-as debug-menu-item-var arg0) display-str) (-> arg1 context font)))) ) (else (set! v0-1 (+ (the int (get-string-length (-> arg0 name) (-> arg1 context font))) 6)) ) ) v0-1 ) (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) (set! (-> menu items) (the-as pair (append! (-> menu items) (dcons item '())))) ;; was normal cons (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 ((arg0 debug-menu)) "Remove all the items from a menu" (let* ((gp-0 (-> arg0 context)) (s4-0 (-> gp-0 is-active)) ) (if s4-0 (debug-menu-context-send-msg gp-0 (debug-menu-msg deactivate) (debug-menu-dest activation)) ) (set! (-> arg0 items) '()) (set! (-> arg0 selected-item) #f) (debug-menu-rebuild arg0) (if s4-0 (debug-menu-context-send-msg gp-0 (debug-menu-msg activate) (debug-menu-dest activation)) ) ) arg0 ) (defun debug-menu-func-decode ((arg0 object)) "Get a function. The input can be a symbol or a function. Otherwise it will give you the nothing function." (let ((v1-1 (rtype-of arg0))) (the-as function (cond ((or (= v1-1 symbol) (= v1-1 type)) (-> (the-as symbol arg0) value) ) ((= v1-1 function) arg0 ) (else nothing ) ) ) ) ) (defun-recursive debug-menu-make-from-template debug-menu-node ((arg0 debug-menu-context) (arg1 pair)) "Make a debug menu from static layout data. The keys are: - menu : make a new submenu - main-menu : make the root menu - flag - flag entry - function - function entry - var, int-var, int-var-gat1, hex-var, float-var, flat-fixed-var" (local-vars (s5-0 debug-menu-node) (sv-16 object) (sv-32 int) (sv-48 float) (sv-64 float) (sv-80 float) (sv-96 float) ) (when (or (not arg1) (null? arg1)) (set! s5-0 (the-as debug-menu-node #f)) (goto cfg-41) ) (let ((s4-0 (car arg1)) (s5-1 (the-as string (cadr arg1))) ) (cond ((= s4-0 'menu) (let ((s4-1 (new 'debug 'debug-menu arg0 s5-1))) (set! s5-0 (new 'debug 'debug-menu-item-submenu s5-1 s4-1)) (let* ((gp-1 (cddr arg1)) (a1-3 (car gp-1)) ) (while (not (null? gp-1)) (let ((a1-4 (debug-menu-make-from-template arg0 (the-as pair a1-3)))) (if a1-4 (debug-menu-append-item s4-1 (the-as debug-menu-item a1-4)) ) ) (set! gp-1 (cdr gp-1)) (set! a1-3 (car gp-1)) ) ) ) ) ((= s4-0 'main-menu) (set! s5-0 (new 'debug 'debug-menu arg0 s5-1)) (let* ((gp-2 (cddr arg1)) (a1-6 (car gp-2)) ) (while (not (null? gp-2)) (let ((a1-7 (debug-menu-make-from-template arg0 (the-as pair a1-6)))) (if a1-7 (debug-menu-append-item (the-as debug-menu s5-0) (the-as debug-menu-item a1-7)) ) ) (set! gp-2 (cdr gp-2)) (set! a1-6 (car gp-2)) ) ) (debug-menu-context-set-root-menu arg0 (the-as debug-menu s5-0)) ) (else (set! s5-0 (cond ((= s4-0 'flag) (new 'debug 'debug-menu-item-flag s5-1 (the-as int (caddr arg1)) (the (function int debug-menu-msg object) (debug-menu-func-decode (cadddr arg1))) ) ) ((or (= s4-0 0) (= s4-0 'function)) (new 'debug 'debug-menu-item-function s5-1 (the-as int (caddr arg1)) (the (function int object) (debug-menu-func-decode (cadddr arg1))) ) ) ((= s4-0 'var) (new 'debug 'debug-menu-item-var s5-1 (the-as int (caddr arg1)) (the-as int (cadddr arg1))) ) ((or (= s4-0 'int-var) (= s4-0 'int-var-gat1) (= s4-0 'hex-var) ) (set! s5-0 (new 'debug 'debug-menu-item-var s5-1 (the-as int (caddr arg1)) (the-as int (ref arg1 4)))) (debug-menu-item-var-make-int (the-as debug-menu-item-var s5-0) (the-as (function int debug-menu-msg int int int) (debug-menu-func-decode (cadddr arg1))) (/ (the-as int (ref arg1 5)) 8) (the-as symbol (ref arg1 6)) (/ (the-as int (ref arg1 7)) 8) (/ (the-as int (ref arg1 8)) 8) (= s4-0 'hex-var) ) ;; changed... i have no idea what they were trying to do here (set! (-> (the-as debug-menu-item-var s5-0) ifloat-p) (= s4-0 'int-var-gat1));;#t) s5-0 ) ((= s4-0 'float-var) (set! s5-0 (new 'debug 'debug-menu-item-var s5-1 (the-as int (caddr arg1)) (the-as int (ref arg1 4)))) (debug-menu-item-var-make-float (the-as debug-menu-item-var s5-0) (the-as (function int debug-menu-msg float float float) (debug-menu-func-decode (cadddr arg1))) (the float (/ (the-as int (ref arg1 5)) 8)) (the-as symbol (ref arg1 6)) (the float (/ (the-as int (ref arg1 7)) 8)) (the float (/ (the-as int (ref arg1 8)) 8)) (/ (the-as int (ref arg1 9)) 8) ) s5-0 ) ((= s4-0 'float-fixed-var) (set! s5-0 (new 'debug 'debug-menu-item-var s5-1 (the-as int (caddr arg1)) (the-as int (ref arg1 4)))) (debug-menu-item-var-make-float (the-as debug-menu-item-var s5-0) (the-as (function int debug-menu-msg float float float) (debug-menu-func-decode (cadddr arg1))) (* 0.001 (the float (/ (the-as int (ref arg1 5)) 8))) (the-as symbol (ref arg1 6)) (* 0.001 (the float (/ (the-as int (ref arg1 7)) 8))) (* 0.001 (the float (/ (the-as int (ref arg1 8)) 8))) (/ (the-as int (ref arg1 9)) 8) ) s5-0 ) (else (the-as debug-menu-node #f) ) ) ) ) ) ) (label cfg-41) s5-0 ) (defun debug-menu-find-from-template ((arg0 debug-menu-context) (arg1 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 ((s4-0 (the-as object (-> arg0 root-menu)))) (while (begin (label cfg-17) (and s4-0 (type-type? (-> (the-as debug-menu-node s4-0) type) debug-menu) (not (null? arg1)) ) ) (let ((s3-0 (-> (the-as debug-menu s4-0) items)) (s4-1 (the-as string (car arg1))) ) (set! arg1 (cdr arg1)) (let ((s5-0 (car s3-0))) (while (not (null? s3-0)) (when (string= s4-1 (-> (the-as debug-menu-item s5-0) name)) (if (type-type? (rtype-of s5-0) debug-menu-item-submenu) (set! s4-0 (-> (the-as debug-menu-item-submenu s5-0) submenu)) (set! s4-0 s5-0) ) (goto cfg-17) ) (set! s3-0 (cdr s3-0)) (set! s5-0 (car s3-0)) ) ) ) (set! s4-0 #f) (goto cfg-24) ) (label cfg-24) (the-as debug-menu s4-0) ) ) ;;;;;;;;;;;;;;;;;;;;;;;; ;; 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 ((s5-0 (-> item parent context font))) (set-origin! s5-0 x y) (set! (-> s5-0 color) (cond ((zero? submenus) (font-color dim-white)) ;; in the active menu, white (selected (font-color dark-light-blue)) ;; a parent, but selected (else (font-color dim-gray)) ;; a parent, but not selected )) (with-dma-buffer-add-bucket ((s3-0 (-> (current-frame) debug-buf)) (bucket-id debug-no-zbuf)) ;; NOTE: the draw-string-adv advances too far on widescreen. ;; NOTE 2: should be fixed? (draw-string-adv (-> item name) s3-0 s5-0) (draw-string-adv "..." s3-0 s5-0) ) ) 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 ((v1-2 (-> item parent context font))) (set-origin! v1-2 x y) (set! (-> v1-2 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 lighter-blue) ) ((< (-> item hilite-timer) 0) ;; if we're negative, it failed, so hilite in red (1+! (-> item hilite-timer)) (font-color orange-red-2) ) ((nonzero? submenus) ;; in a parent menu (font-color dim-gray) ) (else ;; option in the active menu. (font-color dim-white) ) ) ) (with-dma-buffer-add-bucket ((s4-0 (-> (current-frame) debug-buf)) (bucket-id debug-no-zbuf)) (draw-string (-> item name) s4-0 v1-2) ) ) item ) (defun debug-menu-item-flag-render ((item debug-menu-item-flag) (x int) (y int) (submenus int) (arg4 symbol)) "Draw the text for a flag." (let ((v1-2 (-> item parent context font))) (set-origin! v1-2 x y) (set! (-> v1-2 color) (cond ((= (-> item is-on) 'invalid) (font-color flat-dark-purple) ;; can't use this one. ) ((-> item is-on) (if (zero? submenus) (font-color yellow-green) ;; on, and in active menu (font-color dark-green) ;; on, and in parent menu ) ) ((zero? submenus) (font-color another-gray) ;; off, and in active menu ) (else (font-color dark-dark-green) ;; off, and in parent menu ) ) ) (with-dma-buffer-add-bucket ((s4-0 (-> (current-frame) debug-buf)) (bucket-id debug-no-zbuf)) (draw-string (-> item name) s4-0 v1-2) ) ) 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 ((s5-0 (-> item parent context font))) (set-origin! s5-0 x y) (set! (-> s5-0 color) (cond ((zero? submenus) (if (-> item grabbed-joypad-p) (font-color lighter-blue) ;; active menu, using joypad (font-color dim-white) ;; active menu, but not grabbed ) ) (selected (font-color dark-light-blue) ;; not sure how this case can happen ) (else (font-color dim-gray) ) ) ) (with-dma-buffer-add-bucket ((s1-0 (-> (current-frame) debug-buf)) (bucket-id debug-no-zbuf)) (draw-string-adv (-> item name) s1-0 s5-0) (draw-string-adv ":" s1-0 s5-0) (cond ((>= (-> item show-len) (length (-> item display-str))) ;; enough room to just draw the whole thing (draw-string (-> item display-str) s1-0 s5-0) ) (else ;; not enough room. normally just draw ... (draw-string "..." s1-0 s5-0) ;; display the whole thing if: we're selected and there are no submenus. (set! selected (and (zero? submenus) selected)) (when selected (set-origin! s5-0 20 204) (draw-string-adv (-> item name) s1-0 s5-0) (draw-string-adv ":" s1-0 s5-0) (draw-string (-> item display-str) s1-0 s5-0) ) ) ) ) ) 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 ((v1-0 0)) (let* ((a0-1 (-> menu items)) (a1-1 (car a0-1)) ) (while (not (null? a0-1)) (if (= a1-1 selected) (goto cfg-7) ) (+! v1-0 1) (set! a0-1 (cdr a0-1)) (set! a1-1 (car a0-1)) ) ) (label cfg-7) (if (< 16 v1-0) (set! y-pos (- y-pos (* (+ v1-0 -16) 8))) ) ) (with-dma-buffer-add-bucket ((s0-0 (-> (current-frame) debug-buf)) (bucket-id debug-no-zbuf)) ;; PC PORT : fixed for widescreen (draw-sprite2d-xy s0-0 (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* ((s3-1 (+ x-pos 3)) (s2-1 (+ y-pos 3)) (s1-1 (-> menu items)) (s0-1 (car s1-1)) ) (while (not (null? s1-1)) ;; draw > on the selected object (when (= s0-1 selected) ;; dim it if it's in a parent menu. (set! (-> menu context font color) (if (nonzero? submenus) (font-color dim-gray) (font-color dim-white) ) ) (set-origin! (-> menu context font) s3-1 s2-1) (with-dma-buffer-add-bucket ((sv-16 (-> (current-frame) debug-buf)) (bucket-id debug-no-zbuf)) (draw-string ">" sv-16 (-> menu context font)) ) ) ;; actually draw the item. ;; PC PORT note : do not render if text is out of bounds... (when (and (< -20 s2-1) (> 256 s2-1)) (debug-menu-item-render (the-as debug-menu-item s0-1) (+ s3-1 12) s2-1 submenus (= s0-1 selected)) ) (+! s2-1 8) (set! s1-1 (cdr s1-1)) (set! s0-1 (car s1-1)) ) ) menu ) (defun debug-menu-context-render ((arg0 debug-menu-context)) "Render all menus" (let ((x-pos 6)) ;; loop down the stack of menus (dotimes (stack-idx (-> arg0 sel-length)) ;; the menu being drawn at this depth (let ((menu (-> arg0 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) (-> arg0 sel-length))) ) (set! x-pos (+ x-pos 3 (-> menu pix-width))) ) ) ) arg0 ) ;;;;;;;;;;;;;;;;;;;;;;;; ;; navigate ;;;;;;;;;;;;;;;;;;;;;;;; (defun debug-menu-context-select-next-or-prev-item ((arg0 debug-menu-context) (arg1 int)) "Go up or down 1 in the currently open thing. The sign of arg1 determines direction" (local-vars (v1-6 object)) ;; search for the currently selected thing. (let ((s5-0 (-> arg0 sel-menu (+ (-> arg0 sel-length) -1)))) (let ((a2-0 (-> s5-0 selected-item)) (a0-1 '()) ;; thing before selection (v1-4 '()) ;; current selection ) (let ((a3-0 (-> s5-0 items))) (while (not (null? a3-0)) (if (= (car a3-0) a2-0) (begin (set! v1-4 a3-0) (goto cfg-7) ) ) (set! a0-1 a3-0) (set! a3-0 (cdr a3-0)) ) ) (label cfg-7) (if (null? v1-4) (begin (format 0 "ERROR: Couldn't find selected item in menu.~%") (set! arg0 arg0) (goto cfg-19) ) ) (cond ((>= arg1 0) (if (null? (cdr v1-4)) (set! v1-6 (car (-> s5-0 items))) ;; wrap (set! v1-6 (car (cdr v1-4))) ;; get next ) ) ((null? a0-1) (set! v1-6 (car (last (-> s5-0 items)))) ;; wrap backward ) (else (set! v1-6 (car a0-1)) ;; get prev. ) ) ) (set! (-> s5-0 selected-item) (the-as debug-menu-item v1-6)) ) (label cfg-19) arg0 ) (defun debug-menu-context-select-new-item ((arg0 debug-menu-context) (arg1 int)) (let* ((a2-0 (-> arg0 sel-menu (+ (-> arg0 sel-length) -1))) (a1-1 (-> a2-0 selected-item)) (a0-1 0) (v1-4 -1) ) (let ((a2-1 (-> a2-0 items))) (while (not (null? a2-1)) (if (= (car a2-1) a1-1) (set! v1-4 a0-1) ) (set! a2-1 (cdr a2-1)) (+! a0-1 1) ) ) (if (= v1-4 -1) (begin (format 0 "ERROR: Couldn't find selected item in menu.~%") (set! arg0 arg0) (goto cfg-25) ) ) (cond ((>= arg1 0) (cond ((= v1-4 (+ a0-1 -1)) (set! arg1 1) ) ((>= (+ v1-4 arg1) a0-1) (set! arg1 (+ (- -1 v1-4) a0-1)) ) ) (dotimes (s4-0 arg1) (debug-menu-context-select-next-or-prev-item arg0 1) ) ) (else (cond ((zero? v1-4) (set! arg1 -1) ) ((< (+ v1-4 arg1) 0) (set! arg1 (- v1-4)) ) ) (dotimes (s4-1 (- arg1)) (debug-menu-context-select-next-or-prev-item arg0 -1) ) ) ) ) (label cfg-25) arg0 ) (defun debug-menu-context-open-submenu ((arg0 debug-menu-context) (arg1 debug-menu)) (let ((v1-0 (-> arg0 sel-length))) (when (>= v1-0 8) (format 0 "ERROR: Trying to exceed maximum menu depth!") (return arg1) ) (when (null? (-> arg1 items)) (format 0 "ERROR: Submenu has no items!") (return arg1) ) (set! (-> arg0 sel-menu v1-0) arg1) (if (not (-> arg1 selected-item)) (set! (-> arg1 selected-item) (the-as debug-menu-item (-> arg1 items car))) ) (set! (-> arg0 sel-length) (+ v1-0 1)) ) (debug-menu-context-send-msg arg0 (debug-menu-msg activate) (debug-menu-dest current-selection)) ) (defun debug-menu-context-close-submenu ((arg0 debug-menu-context)) (debug-menu-context-send-msg arg0 (debug-menu-msg deactivate) (debug-menu-dest current-selection)) (if (< 1 (-> arg0 sel-length)) (+! (-> arg0 sel-length) -1) ) arg0 ) ;;;;;;;;;;;;;;;;;;;;;;;; ;; message handling ;;;;;;;;;;;;;;;;;;;;;;;; ;; items each have their own handlers for messages. (defun debug-menu-item-submenu-msg ((arg0 debug-menu-item-submenu) (arg1 debug-menu-msg)) ;; on press, open the submenu (when (= arg1 (debug-menu-msg press)) (let ((a0-1 (-> arg0 parent context))) (debug-menu-context-open-submenu a0-1 (-> arg0 submenu)) ) ) arg0 ) (defun debug-menu-item-function-msg ((arg0 debug-menu-item-function) (arg1 debug-menu-msg)) (cond ((= arg1 (debug-menu-msg press)) ;; on press, call the function! (cond ((-> arg0 activate-func) (if ((-> arg0 activate-func) (-> arg0 id)) (set! (-> arg0 hilite-timer) 6) (set! (-> arg0 hilite-timer) -6) ) ) (else (set! (-> arg0 hilite-timer) -6) ) ) ) ((= arg1 (debug-menu-msg deactivate)) ;; on deactivate, clear hilite. (set! (-> arg0 hilite-timer) 0) 0 ) ) arg0 ) (defun debug-menu-item-flag-msg ((arg0 debug-menu-item-flag) (arg1 debug-menu-msg)) (cond ((= arg1 (debug-menu-msg press)) ;; on press, call the function. (if (-> arg0 activate-func) (set! (-> arg0 is-on) ((-> arg0 activate-func) (-> arg0 id) (debug-menu-msg press))) ) ;; also update all open menus. (let ((a0-2 (-> arg0 parent context))) (debug-menu-context-send-msg a0-2 (debug-menu-msg update) (debug-menu-dest open-menus) ) ) ) ((or (= arg1 (debug-menu-msg update)) (= arg1 (debug-menu-msg activate))) ;; just query the value. (if (-> arg0 activate-func) (set! (-> arg0 is-on) ((-> arg0 activate-func) (-> arg0 id) (debug-menu-msg update))) ) ;; update the refresh counter. (set! (-> arg0 refresh-ctr) (-> arg0 refresh-delay)) ) ) arg0 ) ;;;;;;;;;;;;;;;;;;;;;;;; ;; joypad handling ;;;;;;;;;;;;;;;;;;;;;;;; (defun debug-menu-item-var-joypad-handler ((arg0 debug-menu-item-var)) "Handle joypad inputs for a variable" (cond ((not (cpad-hold? 0 x)) (let ((a0-1 (-> arg0 parent context))) (debug-menu-context-release-joypad a0-1) ) (set! (-> arg0 grabbed-joypad-p) #f) (when (cpad-pressed? 0 circle) (cond ((-> arg0 float-p) (if (-> arg0 factivate-func) (set! (-> arg0 fval) ((-> arg0 factivate-func) (-> arg0 id) (debug-menu-msg press) (-> arg0 fundo-val) (-> arg0 fval))) ) ) (else (if (-> arg0 iactivate-func) (set! (-> arg0 ival) ((-> arg0 iactivate-func) (-> arg0 id) (debug-menu-msg press) (-> arg0 iundo-val) (-> arg0 ival))) ) ) ) (debug-menu-item-var-update-display-str arg0) ) (let ((a0-5 (-> arg0 parent context))) (debug-menu-context-send-msg a0-5 (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 ((v1-39 (cond ((cpad-hold? 0 right) 10) ((cpad-hold? 0 up) 1) ((cpad-hold? 0 down) -1) (else -10) ))) (when (!= v1-39 (-> arg0 inc-dir)) (set! (-> arg0 inc-dir) v1-39) (set! (-> arg0 inc-delay) 15) (set! (-> arg0 inc-delay-ctr) 0) (set! (-> arg0 step-delay-ctr) 30) (set! (-> arg0 fstep) (-> arg0 fstart-inc)) (set! (-> arg0 fstep) (-> arg0 fstart-inc)) ) ) (cond ((<= (-> arg0 inc-delay-ctr) 0) (if (> (-> arg0 inc-delay) 0) (+! (-> arg0 inc-delay) -1) ) (when (zero? (-> arg0 inc-delay)) (cond ((<= (-> arg0 step-delay-ctr) 0) (set! (-> arg0 step-delay-ctr) 30) (cond ((-> arg0 float-p) (if (< (-> arg0 fstep) 10000000.0) (set! (-> arg0 fstep) (* 2.0 (-> arg0 fstep))) ) ) (else (if (< (-> arg0 istep) 10000000) (set! (-> arg0 istep) (* 2 (-> arg0 istep))) ) ) ) ) (else (+! (-> arg0 step-delay-ctr) -1) ) ) ) (set! (-> arg0 inc-delay-ctr) (-> arg0 inc-delay)) (cond ((-> arg0 float-p) (when (-> arg0 factivate-func) (let ((f0-8 (+ (-> arg0 fval) (* (the float (-> arg0 inc-dir)) (-> arg0 fstep))))) (if (-> arg0 range-p) (set! f0-8 (fmin (fmax f0-8 (-> arg0 frange-min)) (-> arg0 frange-max)) ) ) (set! (-> arg0 fval) ((-> arg0 factivate-func) (-> arg0 id) (debug-menu-msg press) f0-8 (-> arg0 fval))) ) ) ) (else (when (-> arg0 iactivate-func) (let ((a2-4 (+ (-> arg0 ival) (* (-> arg0 inc-dir) (-> arg0 istep))))) (if (-> arg0 range-p) (set! a2-4 (min (max a2-4 (-> arg0 irange-min)) (-> arg0 irange-max))) ) (set! (-> arg0 ival) ((-> arg0 iactivate-func) (-> arg0 id) (debug-menu-msg press) a2-4 (-> arg0 ival))) ) ) ) ) (debug-menu-item-var-update-display-str arg0) (let ((a0-20 (-> arg0 parent context))) (debug-menu-context-send-msg a0-20 (debug-menu-msg update) (debug-menu-dest current-selection)) ) ) (else (+! (-> arg0 inc-delay-ctr) -1) ) ) ) (else (set! (-> arg0 inc-dir) 0) ) ) arg0 ) (defun debug-menu-item-var-msg ((arg0 debug-menu-item-var) (arg1 debug-menu-msg)) (cond ((= arg1 (debug-menu-msg deactivate)) (when (-> arg0 grabbed-joypad-p) (let ((a0-1 (-> arg0 parent context))) (debug-menu-context-release-joypad a0-1) ) (set! (-> arg0 grabbed-joypad-p) #f) ) ) ((= arg1 (debug-menu-msg press)) (when (not (-> arg0 grabbed-joypad-p)) (let ((a0-2 (-> arg0 parent context))) (when (debug-menu-context-grab-joypad a0-2 arg0 (the (function basic none) debug-menu-item-var-joypad-handler)) (set! (-> arg0 grabbed-joypad-p) #t) (set! (-> arg0 fundo-val) (-> arg0 fval)) (set! (-> arg0 fundo-val) (-> arg0 fval)) (set! (-> arg0 inc-dir) 0) ) ) ) ) ((or (= arg1 (debug-menu-msg update)) (= arg1 (debug-menu-msg activate))) (cond ((-> arg0 float-p) (if (-> arg0 factivate-func) (set! (-> arg0 fval) ((-> arg0 factivate-func) (-> arg0 id) (debug-menu-msg update) (-> arg0 fval) (-> arg0 fval))) ) ) (else (if (-> arg0 iactivate-func) (set! (-> arg0 ival) ((-> arg0 iactivate-func) (-> arg0 id) (debug-menu-msg update) (-> arg0 ival) (-> arg0 ival))) ) ) ) (debug-menu-item-var-update-display-str arg0) (set! (-> arg0 refresh-ctr) (-> arg0 refresh-delay)) ) ) arg0 ) (defun debug-menu-item-send-msg ((arg0 debug-menu-item) (arg1 debug-menu-msg)) "Call the appropriate message handler for the given item." (cond ((= (-> arg0 type) debug-menu-item-submenu) (debug-menu-item-submenu-msg (the-as debug-menu-item-submenu arg0) arg1) ) ((= (-> arg0 type) debug-menu-item-function) (debug-menu-item-function-msg (the-as debug-menu-item-function arg0) arg1) ) ((= (-> arg0 type) debug-menu-item-flag) (debug-menu-item-flag-msg (the-as debug-menu-item-flag arg0) arg1) ) ((= (-> arg0 type) debug-menu-item-var) (debug-menu-item-var-msg (the-as debug-menu-item-var arg0) arg1) ) (else (format 0 "ERROR: Found unknown item type!~%") ) ) arg0 ) (defun-recursive debug-menu-send-msg debug-menu ((arg0 debug-menu) (arg1 debug-menu-msg) (arg2 symbol)) "Send to all items in menu. Arg2 picks if we are recursive or not." (let* ((s3-0 (-> arg0 items)) (s2-0 (car s3-0)) ) (while (not (null? s3-0)) (debug-menu-item-send-msg (the-as debug-menu-item s2-0) arg1) (if (and arg2 (= (-> (the-as debug-menu-item s2-0) type) debug-menu-item-submenu)) (debug-menu-send-msg (-> (the-as debug-menu-item-submenu s2-0) submenu) arg1 #t) ) (set! s3-0 (cdr s3-0)) (set! s2-0 (car s3-0)) ) ) arg0 ) (defun debug-menu-context-send-msg ((arg0 debug-menu-context) (arg1 debug-menu-msg) (arg2 debug-menu-dest)) "Send the arg1 message to the given place." (cond ((= arg2 (debug-menu-dest root)) ;; sent to root, recursively. This will hit the whole menu. (debug-menu-send-msg (-> arg0 root-menu) arg1 #t) ) ((= arg2 (debug-menu-dest open-menus)) ;; only send to open things (when (-> arg0 is-active) ;; only if context is open (dotimes (s4-0 (-> arg0 sel-length)) ;; go through stack (let ((a0-2 (-> arg0 sel-menu s4-0))) ;; send, not recursive (debug-menu-send-msg a0-2 arg1 #f) ) ) ) ) ((= arg2 (debug-menu-dest current-selection)) (when (-> arg0 is-active) ;; context open (if (nonzero? (-> arg0 sel-length)) ;; something in the stack (debug-menu-send-msg (-> arg0 sel-menu (+ (-> arg0 sel-length) -1)) arg1 #f) ;; send to that. ) ) ) ((= arg2 (debug-menu-dest activation)) ;; this is a special case for when we want to activate or deactivate something. (cond ((= arg1 (debug-menu-msg activate)) (when (not (-> arg0 is-active)) (set! (-> arg0 is-active) #t) (debug-menu-context-send-msg arg0 (debug-menu-msg activate) (debug-menu-dest open-menus)) ) ) ((= arg1 (debug-menu-msg deactivate)) (when (-> arg0 is-active) (debug-menu-context-send-msg arg0 (debug-menu-msg deactivate) (debug-menu-dest open-menus)) (set! (-> arg0 is-active) #f) ) ) ) ) ) arg0 ) (defun debug-menu-context-activate-selection ((arg0 debug-menu-context)) "Press on the selected thing. Note that we named this enum press, not activate." (let ((a0-1 (-> arg0 sel-menu (+ (-> arg0 sel-length) -1) selected-item))) (debug-menu-item-send-msg a0-1 (debug-menu-msg press)) ) arg0 ) (defun debug-menus-default-joypad-func ((arg0 debug-menu-context)) "Control the menu from the joystick" (cond ((cpad-pressed? 0 square) (if (< 1 (-> arg0 sel-length)) (debug-menu-context-close-submenu arg0) ) ) ((cpad-pressed? 0 x) (debug-menu-context-activate-selection arg0) ) ((cpad-pressed? 0 up) (debug-menu-context-select-new-item arg0 -1) ) ((cpad-pressed? 0 down) (debug-menu-context-select-new-item arg0 1) ) ((cpad-pressed? 0 left) (debug-menu-context-select-new-item arg0 -5) ) ((cpad-pressed? 0 right) (debug-menu-context-select-new-item arg0 5) ) ) arg0 ) (defun debug-menus-active ((arg0 debug-menu-context)) "Run the menu context" (when (not (-> arg0 is-hidden)) ;; grab inputs (if (-> arg0 joypad-func) ((-> arg0 joypad-func) (-> arg0 joypad-item)) (debug-menus-default-joypad-func arg0) ) ;; render (debug-menu-context-render arg0) ) arg0 ) (defun debug-menus-handler ((arg0 debug-menu-context)) (if (-> arg0 is-active) (debug-menus-active arg0) ) arg0 ) )