intrinsics.ps
307 lines
| 7.9 KiB
| application/postscript
|
PostScriptLexer
/ src / intrinsics.ps
r1 | ||||
(in-package sugar-qsp) | ||||
r6 | ;;;; Functions and procedures defined by the QSP language. | |||
r1 | ;;;; They can call api and deal with locations and other data directly. | |||
;;;; Except vars. Use VAR and SET or GET-VAR and SET-VAR api calls. | ||||
r6 | (setf (root lib) (ps:create)) | |||
r1 | ||||
;;; 1loc | ||||
r16 | (defm (root lib goto) (target args) | |||
r1 | (api-call clear-text :main) | |||
r16 | (funcall (root lib xgoto) target (or args (list))) | |||
(values)) | ||||
r1 | ||||
r16 | (defm (root lib xgoto) (target args) | |||
r1 | (api-call clear-act) | |||
r11 | (setf (root current-location) (ps:chain target (to-upper-case))) | |||
r16 | (api-call stash-state args) | |||
(funcall (ps:getprop (root locs) (root current-location)) | ||||
(or args (list))) | ||||
(values)) | ||||
r1 | ||||
;;; 2var | ||||
;;; 3expr | ||||
;;; 4code | ||||
r11 | (defm (root lib rand) (a &optional (b 1)) | |||
r1 | (let ((min (min a b)) | |||
(max (max a b))) | ||||
(+ min (ps:chain *math (random (- max min)))))) | ||||
;;; 5arrays | ||||
r6 | (defm (root lib copyarr) (to from start count) | |||
r16 | (multiple-value-bind (to-name to-slot) | |||
(api-call var-real-name to) | ||||
(multiple-value-bind (from-name from-slot) | ||||
(api-call var-real-name from) | ||||
(ps:for ((i start)) | ||||
((< i (min (api-call array-size from-name) | ||||
(+ start count)))) | ||||
((incf i)) | ||||
(api-call set-var to-name (+ start i) to-slot | ||||
(api-call get-var from-name (+ start i) from-slot)))))) | ||||
r1 | ||||
r6 | (defm (root lib arrpos) (name value &optional (start 0)) | |||
r16 | (multiple-value-bind (real-name slot) | |||
(api-call var-real-name name) | ||||
(ps:for ((i start)) ((< i (api-call array-size name))) ((incf i)) | ||||
(when (eq (api-call get-var real-name i slot) value) | ||||
(return i)))) | ||||
r1 | -1) | |||
r6 | (defm (root lib arrcomp) (name pattern &optional (start 0)) | |||
r16 | (multiple-value-bind (real-name slot) | |||
(api-call var-real-name name) | ||||
(ps:for ((i start)) ((< i (api-call array-size name))) ((incf i)) | ||||
(when (funcall (ps:getprop (api-call get-var real-name i slot) 'match) pattern) | ||||
(return i)))) | ||||
r1 | -1) | |||
;;; 6str | ||||
r6 | (defm (root lib instr) (s subs &optional (start 1)) | |||
r1 | (+ start (ps:chain s (substring (- start 1)) (search subs)))) | |||
r6 | (defm (root lib isnum) (s) | |||
r1 | (if (is-na-n s) | |||
0 | ||||
-1)) | ||||
r6 | (defm (root lib strcomp) (s pattern) | |||
r1 | (if (s.match pattern) | |||
-1 | ||||
0)) | ||||
r6 | (defm (root lib strfind) (s pattern group) | |||
r1 | (let* ((re (ps:new (*reg-exp pattern))) | |||
(match (re.exec s))) | ||||
(match.group group))) | ||||
r6 | (defm (root lib strpos) (s pattern &optional (group 0)) | |||
r1 | (let* ((re (ps:new (*reg-exp pattern))) | |||
(match (re.exec s)) | ||||
(found (match.group group))) | ||||
(if found | ||||
(s.search found) | ||||
0))) | ||||
;;; 7if | ||||
r11 | ;; Has to be a function because it always evaluates all three of its | |||
;; arguments | ||||
r6 | (defm (root lib iif) (cond-expr then-expr else-expr) | |||
r11 | (if cond-expr then-expr else-expr)) | |||
r1 | ||||
;;; 8sub | ||||
r6 | (defm (root lib gosub) (target &rest args) | |||
r16 | (funcall (ps:getprop (root locs) target) args) | |||
(values)) | ||||
r1 | ||||
r6 | (defm (root lib func) (target &rest args) | |||
r16 | (funcall (ps:getprop (root locs) target) args)) | |||
r1 | ||||
;;; 9loops | ||||
;;; 10dynamic | ||||
r16 | (defm (root lib dynamic) (block &rest args) | |||
r20 | (when (stringp block) | |||
(api-call report-error "DYNAMIC can't evaluate arbitrary strings.\nUse {braces} to create blocks for DYNAMIC.")) | ||||
r16 | (funcall block args) | |||
(values)) | ||||
r1 | ||||
r16 | (defm (root lib dyneval) (block &rest args) | |||
r20 | (when (stringp block) | |||
(api-call report-error "DYNEVAL can't evaluate arbitrary strings.\nUse {braces} to create blocks for DYNEVAL.")) | ||||
r16 | (funcall block args)) | |||
r1 | ||||
;;; 11main | ||||
r6 | (defm (root lib main-p) (s) | |||
r11 | (api-call add-text :main s) | |||
(values)) | ||||
r1 | ||||
r6 | (defm (root lib main-pl) (s) | |||
(api-call add-text :main s) | ||||
r11 | (api-call newline :main) | |||
(values)) | ||||
r1 | ||||
r6 | (defm (root lib main-nl) (s) | |||
(api-call newline :main) | ||||
r11 | (api-call add-text :main s) | |||
(values)) | ||||
r1 | ||||
r6 | (defm (root lib maintxt) (s) | |||
r11 | (api-call get-text :main) | |||
(values)) | ||||
r1 | ||||
r11 | ;; For clarity (it leaves a lib.desc() call in JS) | |||
r6 | (defm (root lib desc) (s) | |||
r10 | "") | |||
r1 | ||||
r6 | (defm (root lib main-clear) () | |||
r11 | (api-call clear-text :main) | |||
(values)) | ||||
r1 | ||||
r6 | ;;; 12stat | |||
r1 | ||||
r11 | (defm (root lib stat-p) (s) | |||
(api-call add-text :stat s) | ||||
(values)) | ||||
r1 | ||||
r11 | (defm (root lib stat-pl) (s) | |||
(api-call add-text :stat s) | ||||
(api-call newline :stat) | ||||
(values)) | ||||
r1 | ||||
r11 | (defm (root lib stat-nl) (s) | |||
(api-call newline :stat) | ||||
(api-call add-text :stat s) | ||||
(values)) | ||||
r1 | ||||
r11 | (defm (root lib stattxt) (s) | |||
(api-call get-text :stat) | ||||
(values)) | ||||
r1 | ||||
r11 | (defm (root lib stat-clear) () | |||
(api-call clear-text :stat) | ||||
(values)) | ||||
r1 | ||||
r11 | (defm (root lib cls) () | |||
(funcall (root lib stat-clear)) | ||||
(funcall (root lib main-clear)) | ||||
(funcall (root lib cla)) | ||||
(funcall (root lib cmdclear)) | ||||
(values)) | ||||
r1 | ||||
;;; 13diag | ||||
;;; 14act | ||||
r11 | (defm (root lib curacts) () | |||
(let ((acts (root acts))) | ||||
(lambda () | ||||
(setf (root acts) acts) | ||||
(values)))) | ||||
r1 | ||||
;;; 15objs | ||||
r6 | (defm (root lib addobj) (name) | |||
(ps:chain (root objs) (push name)) | ||||
r11 | (api-call update-objs) | |||
(values)) | ||||
r1 | ||||
r6 | (defm (root lib delobj) (name) | |||
(let ((index (ps:chain (root objs) (index-of name)))) | ||||
(when (> index -1) | ||||
r12 | (funcall (root lib killobj) (1+ index)))) | |||
r11 | (values)) | |||
r1 | ||||
r12 | (defm (root lib killobj) (&optional (num nil)) | |||
(if (eq nil num) | ||||
(setf (root objs) (list)) | ||||
(ps:chain (root objs) (splice (1- num) 1))) | ||||
r11 | (api-call update-objs) | |||
(values)) | ||||
r1 | ||||
;;; 16menu | ||||
r11 | (defm (root lib menu) (menu-name) | |||
(let ((menu-data (list))) | ||||
r14 | (loop :for item :in (api-call get-array (api-call var-real-name menu-name)) | |||
r11 | :do (cond ((string= item "") | |||
(break)) | ||||
((string= item "-:-") | ||||
(ps:chain menu-data (push :delimiter))) | ||||
(t | ||||
(let* ((tokens (ps:chain item (split ":")))) | ||||
(when (= (length tokens) 2) | ||||
(tokens.push "")) | ||||
(let* ((text (ps:chain tokens (splice 0 (- tokens.length 2)) (join ":"))) | ||||
(loc (ps:getprop tokens (- tokens.length 2))) | ||||
(icon (ps:getprop tokens (- tokens.length 1)))) | ||||
(ps:chain menu-data | ||||
(push (ps:create text text | ||||
loc loc | ||||
icon icon)))))))) | ||||
(api-call menu menu-data) | ||||
(values))) | ||||
r1 | ||||
;;; 17sound | ||||
r12 | (defm (root lib play) (filename &optional (volume 100)) | |||
(let ((audio (ps:new (*audio filename)))) | ||||
(setf (ps:getprop (root playing) filename) audio) | ||||
(setf (ps:@ audio volume) (* volume 0.01)) | ||||
(ps:chain audio (play)))) | ||||
r1 | ||||
r12 | (defm (root lib close) (filename) | |||
(funcall (root playing filename) stop) | ||||
(ps:delete (root playing filename))) | ||||
r1 | ||||
r12 | (defm (root lib closeall) () | |||
(loop :for k :in (*object.keys (root playing)) | ||||
:for v := (ps:getprop (root playing) k) | ||||
:do (funcall v stop)) | ||||
(setf (root playing) (ps:create))) | ||||
r1 | ||||
;;; 18img | ||||
r18 | (defm (root lib refint) () | |||
;; "Force interface update" Uh... what exactly do we do here? | ||||
r20 | (api-call report-error "REFINT is not supported") | |||
r18 | ) | |||
r1 | ||||
;;; 19input | ||||
r20 | (defm (root lib usertxt) () | |||
(let ((input (document.get-element-by-id "qsp-input"))) | ||||
(ps:@ input value))) | ||||
r1 | ||||
r20 | (defm (root lib cmdclear) () | |||
(let ((input (document.get-element-by-id "qsp-input"))) | ||||
(setf (ps:@ input value) ""))) | ||||
r1 | ||||
r20 | (defm (root lib input) (text) | |||
(window.prompt text)) | ||||
r1 | ||||
;;; 20time | ||||
r11 | ;; I wonder if there's a better solution than busy-wait | |||
(defm (root lib wait) (msec) | ||||
(let* ((now (ps:new (*date))) | ||||
(exit-time (+ (funcall now.get-time) msec))) | ||||
(loop :while (< (funcall now.get-time) exit-time)))) | ||||
r1 | ||||
r20 | (defm (root lib msecscount) () | |||
(- (*date.now) (root started-at))) | ||||
r1 | ||||
r14 | ;;; 21local | |||
r18 | ;;; 22for | |||
r1 | ;;; misc | |||
r22 | (defm (root lib rgb) (red green blue) | |||
(flet ((rgb-to-hex (comp) | ||||
(let ((hex (ps:chain (*number comp) (to-string 16)))) | ||||
(if (< (length hex) 2) | ||||
(+ "0" hex) | ||||
hex)))) | ||||
(+ "#" (rgb-to-hex red) (rgb-to-hex green) (rgb-to-hex red)))) | ||||
r1 | ||||
r20 | (defm (root lib openqst) () | |||
(api-call report-error "OPENQST is not supported.")) | ||||
r1 | ||||
r20 | (defm (root lib addqst) () | |||
(api-call report-error "ADDQST is not supported. Bundle the library with the main game.")) | ||||
r1 | ||||
r20 | (defm (root lib killqst) () | |||
(api-call report-error "KILLQST is not supported.")) | ||||