intrinsics.ps
299 lines
| 5.7 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 | ||||
r6 | (defm (root lib goto) (target &rest args) | |||
r1 | (api-call clear-text :main) | |||
r6 | (apply (root lib xgoto) target args)) | |||
r1 | ||||
r6 | (defm (root lib xgoto) (target &rest args) | |||
r1 | (api-call clear-act) | |||
(api-call init-args args) | ||||
(setf (root current-location) target) | ||||
r10 | (api-call stash-state) | |||
r6 | (funcall (ps:getprop (root locations) (ps:chain target (to-upper-case))))) | |||
r1 | ||||
;;; 2var | ||||
r6 | (defm (root lib killvar) (varname &optional (index :whole)) | |||
r1 | (api-call kill-var varname index)) | |||
r6 | (defm (root lib killall) () | |||
r1 | (api-call kill-all)) | |||
;;; 3expr | ||||
r6 | (defm (root lib obj) (name) | |||
r1 | (funcall (root objs includes) name)) | |||
r6 | (defm (root lib loc) () | |||
r1 | (funcall (root locations includes) name)) | |||
r6 | (defm (root lib no) (arg) | |||
r1 | (- -1 arg)) | |||
;;; 4code | ||||
r6 | (defm (root lib qspver) () | |||
r1 | "0.0.1") | |||
r6 | (defm (root lib curloc) () | |||
r1 | (root current-location)) | |||
r6 | (defm (root lib rand) (a b) | |||
r1 | (let ((min (min a b)) | |||
(max (max a b))) | ||||
(+ min (ps:chain *math (random (- max min)))))) | ||||
r6 | (defm (root lib rnd) () | |||
(funcall (root lib rand) 1 1000)) | ||||
r1 | ||||
r6 | (defm (root lib qspmax) (&rest args) | |||
r1 | (apply (ps:@ *math max) args)) | |||
r6 | (defm (root lib qspmin) (&rest args) | |||
r1 | (apply (ps:@ *math min) args)) | |||
;;; 5arrays | ||||
r6 | (defm (root lib copyarr) (to from start count) | |||
r1 | (ps:for ((i start)) | |||
((< i (min (api-call array-size from) | ||||
(+ start count)))) | ||||
((incf i)) | ||||
(api-call set-var to (+ start i) | ||||
(api-call get-var from (+ start i))))) | ||||
r6 | (defm (root lib arrsize) (name) | |||
r1 | (api-call array-size name)) | |||
r6 | (defm (root lib arrpos) (name value &optional (start 0)) | |||
r1 | (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i)) | |||
(when (eq (api-call get-var name i) value) | ||||
(return i))) | ||||
-1) | ||||
r6 | (defm (root lib arrcomp) (name pattern &optional (start 0)) | |||
r1 | (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i)) | |||
(when (funcall (ps:getprop (api-call get-var name i) 'match) pattern) | ||||
(return i))) | ||||
-1) | ||||
;;; 6str | ||||
r6 | (defm (root lib len) (s) | |||
r1 | (length s)) | |||
r6 | (defm (root lib mid) (s from &optional count) | |||
r1 | (s.substring from count)) | |||
r6 | (defm (root lib ucase) (s) | |||
r1 | (s.to-upper-case)) | |||
r6 | (defm (root lib lcase) (s) | |||
r1 | (s.to-lower-case)) | |||
r6 | (defm (root lib trim) (s) | |||
r1 | (s.trim)) | |||
r6 | (defm (root lib replace) (s from to) | |||
r1 | (s.replace from to)) | |||
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 val) (s) | |||
r1 | (parse-int s 10)) | |||
r6 | (defm (root lib qspstr) (n) | |||
r1 | (+ "" n)) | |||
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 | ||||
r6 | (defm (root lib iif) (cond-expr then-expr else-expr) | |||
(if (= -1 cond-expr) then-expr else-expr)) | ||||
r1 | ||||
;;; 8sub | ||||
r6 | (defm (root lib gosub) (target &rest args) | |||
r10 | (conserving-vars (args result) | |||
r1 | (api-call init-args args) | |||
(funcall (ps:getprop (root locations) target)) | ||||
(values))) | ||||
r6 | (defm (root lib func) (target &rest args) | |||
r10 | (conserving-vars (args result) | |||
r1 | (api-call init-args args) | |||
(funcall (ps:getprop (root locations) target)) | ||||
(api-call get-result))) | ||||
;;; 9loops | ||||
;;; 10dynamic | ||||
r6 | (defm (root lib dyneval) (block &rest args) | |||
r10 | (conserving-vars (args result) | |||
r1 | (api-call init-args args) | |||
(funcall block) | ||||
(api-call get-result))) | ||||
r6 | (defm (root lib dynamic) (&rest args) | |||
r10 | (conserving-vars (args result) | |||
r1 | (api-call init-args args) | |||
(funcall block) | ||||
(values))) | ||||
;;; 11main | ||||
r6 | (defm (root lib main-p) (s) | |||
r1 | (api-call add-text :main s)) | |||
r6 | (defm (root lib main-pl) (s) | |||
(api-call add-text :main s) | ||||
(api-call newline :main)) | ||||
r1 | ||||
r6 | (defm (root lib main-nl) (s) | |||
(api-call newline :main) | ||||
(api-call add-text :main s)) | ||||
r1 | ||||
r6 | (defm (root lib maintxt) (s) | |||
r1 | (api-call get-text :main)) | |||
r6 | (defm (root lib desc) (s) | |||
r10 | "") | |||
r1 | ||||
r6 | (defm (root lib main-clear) () | |||
r1 | (api-call clear-text :main)) | |||
r6 | ;;; 12stat | |||
r1 | ||||
r6 | (defm (root lib showstat) ()) | |||
r1 | ||||
r6 | (defm (root lib stat-p) ()) | |||
r1 | ||||
r6 | (defm (root lib stat-pl) ()) | |||
r1 | ||||
r6 | (defm (root lib stat-nl) ()) | |||
r1 | ||||
r6 | (defm (root lib stattxt) ()) | |||
r1 | ||||
r6 | (defm (root lib clear) ()) | |||
r1 | ||||
r6 | (defm (root lib cls) ()) | |||
r1 | ||||
;;; 13diag | ||||
r6 | (defm (root lib msg) ()) | |||
r1 | ||||
;;; 14act | ||||
r6 | (defm (root lib showacts) ()) | |||
r1 | ||||
r6 | (defm (root lib delact) (name) | |||
(api-call del-act name)) | ||||
r1 | ||||
r6 | (defm (root lib curacts) ()) | |||
(defm (root lib cla) ()) | ||||
r1 | ||||
;;; 15objs | ||||
r6 | (defm (root lib showobjs) ()) | |||
r1 | ||||
r6 | (defm (root lib addobj) (name) | |||
(ps:chain (root objs) (push name)) | ||||
(api-call update-objs)) | ||||
r1 | ||||
r6 | (defm (root lib delobj) (name) | |||
(let ((index (ps:chain (root objs) (index-of name)))) | ||||
(when (> index -1) | ||||
(ps:chain (root objs) (splice index 1)))) | ||||
(api-call update-objs)) | ||||
r1 | ||||
r6 | (defm (root lib killobj) ()) | |||
r1 | ||||
r6 | (defm (root lib countobj) ()) | |||
(defm (root lib getobj) ()) | ||||
r1 | ||||
;;; 16menu | ||||
r6 | (defm (root lib menu) ()) | |||
r1 | ||||
;;; 17sound | ||||
r6 | (defm (root lib play) ()) | |||
r1 | ||||
r6 | (defm (root lib isplay) ()) | |||
r1 | ||||
r6 | (defm (root lib close) ()) | |||
r1 | ||||
r6 | (defm (root lib closeall) ()) | |||
r1 | ||||
;;; 18img | ||||
r6 | (defm (root lib refint) ()) | |||
r1 | ||||
r6 | (defm (root lib view) ()) | |||
r1 | ||||
;;; 19input | ||||
r6 | (defm (root lib showinput) ()) | |||
r1 | ||||
r6 | (defm (root lib usertxt) ()) | |||
r1 | ||||
r6 | (defm (root lib cmdclear) ()) | |||
r1 | ||||
r6 | (defm (root lib input) ()) | |||
r1 | ||||
;;; 20time | ||||
r6 | (defm (root lib wait) ()) | |||
r1 | ||||
r6 | (defm (root lib msecscount) ()) | |||
r1 | ||||
r6 | (defm (root lib settimer) ()) | |||
r1 | ||||
;;; misc | ||||
r6 | (defm (root lib rgb) ()) | |||
r1 | ||||
r6 | (defm (root lib openqst) ()) | |||
r1 | ||||
r6 | (defm (root lib addqst) ()) | |||
r1 | ||||
r6 | (defm (root lib killqst) ()) | |||
r1 | ||||
r6 | (defm (root lib opengame) ()) | |||
r1 | ||||
r6 | (defm (root lib savegame) ()) | |||