Show More
@@ -1,15 +1,19 b'' | |||||
1 |
|
1 | |||
2 | <div id="qsp"> |
|
2 | <div id="qsp"> | |
3 | <div class="qsp-col qsp-col1"> |
|
3 | <div class="qsp-col qsp-col1"> | |
4 | <div id="qsp-main" class="qsp-frame"> </div> |
|
4 | <div id="qsp-main" class="qsp-frame"> </div> | |
5 | <div id="qsp-acts" class="qsp-frame"> </div> |
|
5 | <div id="qsp-acts" class="qsp-frame"> </div> | |
6 | <input id="qsp-input" class="qsp-frame"> |
|
6 | <input id="qsp-input" class="qsp-frame"> | |
7 | </div> |
|
7 | </div> | |
8 | <div class="qsp-col qsp-col2"> |
|
8 | <div class="qsp-col qsp-col2"> | |
9 | <div id="qsp-stat" class="qsp-frame"> </div> |
|
9 | <div id="qsp-stat" class="qsp-frame"> </div> | |
10 | <div id="qsp-objs" class="qsp-frame"> </div> |
|
10 | <div id="qsp-objs" class="qsp-frame"> </div> | |
11 | </div> |
|
11 | </div> | |
|
12 | <div class="qsp-col qsp-col3"> | |||
|
13 | <a href="javascript:SugarQSP.lib.savegame()"><img id="qsp-btn-save"></a> | |||
|
14 | <a href="javascript:SugarQSP.lib.opengame()"><img id="qsp-btn-load"></a> | |||
|
15 | </div> | |||
12 | </div> |
|
16 | </div> | |
13 |
|
17 | |||
14 | <div id="qsp-dropdown"> |
|
18 | <div id="qsp-dropdown"> | |
15 | </div> |
|
19 | </div> |
@@ -1,84 +1,103 b'' | |||||
1 |
|
1 | |||
2 | .qsp-frame { |
|
2 | .qsp-frame { | |
3 | border: 1px solid black; |
|
3 | border: 1px solid black; | |
4 | overflow: auto; |
|
4 | overflow: auto; | |
5 | padding: 5px; |
|
5 | padding: 5px; | |
6 | box-sizing: border-box; |
|
6 | box-sizing: border-box; | |
7 | } |
|
7 | } | |
8 |
|
8 | |||
9 | #qsp { |
|
9 | #qsp { | |
10 | position: absolute; |
|
10 | position: absolute; | |
11 | display: flex; |
|
11 | display: flex; | |
12 | flex-flow: row; |
|
12 | flex-flow: row; | |
13 | top: 0; |
|
13 | top: 0; | |
14 | left: 0; |
|
14 | left: 0; | |
15 | width: 100%; |
|
15 | width: 100%; | |
16 | height: 100%; |
|
16 | height: 100%; | |
17 | } |
|
17 | } | |
18 |
|
18 | |||
19 | .qsp-col { |
|
19 | .qsp-col { | |
20 | display: flex; |
|
20 | display: flex; | |
21 | flex-flow: column; |
|
21 | flex-flow: column; | |
22 | } |
|
22 | } | |
23 |
|
23 | |||
24 | .qsp-col1 { |
|
24 | .qsp-col1 { | |
25 | flex: 7 7 70px; |
|
25 | flex: 7 7 70px; | |
26 | } |
|
26 | } | |
27 |
|
27 | |||
28 | .qsp-col2 { |
|
28 | .qsp-col2 { | |
29 | flex: 3 3 30px; |
|
29 | flex: 3 3 30px; | |
30 | } |
|
30 | } | |
31 |
|
31 | |||
|
32 | .qsp-col3 { | |||
|
33 | flex: 0 0 40px; | |||
|
34 | } | |||
|
35 | ||||
32 | #qsp-main { |
|
36 | #qsp-main { | |
33 | flex: 6 6 60px; |
|
37 | flex: 6 6 60px; | |
34 | } |
|
38 | } | |
35 |
|
39 | |||
36 | #qsp-acts { |
|
40 | #qsp-acts { | |
37 | flex: 4 4 40px; |
|
41 | flex: 4 4 40px; | |
38 | } |
|
42 | } | |
39 |
|
43 | |||
40 | #qsp-input { |
|
44 | #qsp-input { | |
41 | } |
|
45 | } | |
42 |
|
46 | |||
43 | #qsp-stat { |
|
47 | #qsp-stat { | |
44 | flex: 5 5 50px; |
|
48 | flex: 5 5 50px; | |
45 | } |
|
49 | } | |
46 |
|
50 | |||
47 | #qsp-objs { |
|
51 | #qsp-objs { | |
48 | flex: 5 5 50px; |
|
52 | flex: 5 5 50px; | |
49 | } |
|
53 | } | |
50 |
|
54 | |||
51 | .qsp-act { |
|
55 | .qsp-act { | |
52 | display: block; |
|
56 | display: block; | |
53 | padding: 2px; |
|
57 | padding: 2px; | |
54 | font-size: large; |
|
58 | font-size: large; | |
55 | } |
|
59 | } | |
56 |
|
60 | |||
57 | .qsp-act:hover { |
|
61 | .qsp-act:hover { | |
58 | outline: #9E9E9E outset 3px |
|
62 | outline: #9E9E9E outset 3px | |
59 | } |
|
63 | } | |
60 |
|
64 | |||
61 |
/ |
|
65 | /* Dropdown */ | |
62 |
|
66 | |||
63 | #qsp-dropdown { |
|
67 | #qsp-dropdown { | |
64 | display: none; |
|
68 | display: none; | |
65 | position: absolute; |
|
69 | position: absolute; | |
66 | background-color: #f1f1f1; |
|
70 | background-color: #f1f1f1; | |
67 | min-width: 160px; |
|
71 | min-width: 160px; | |
68 | overflow: auto; |
|
72 | overflow: auto; | |
69 | box-shadow: 0px 8px 16px 0px rgba(0,0,0,0.2); |
|
73 | box-shadow: 0px 8px 16px 0px rgba(0,0,0,0.2); | |
70 | z-index: 1; |
|
74 | z-index: 1; | |
71 | margin: auto; |
|
75 | margin: auto; | |
72 | top: 200; |
|
76 | top: 200; | |
73 | } |
|
77 | } | |
74 |
|
78 | |||
75 | #qsp-dropdown a { |
|
79 | #qsp-dropdown a { | |
76 | color: black; |
|
80 | color: black; | |
77 | padding: 12px 16px; |
|
81 | padding: 12px 16px; | |
78 | text-decoration: none; |
|
82 | text-decoration: none; | |
79 | display: block; |
|
83 | display: block; | |
80 | } |
|
84 | } | |
81 |
|
85 | |||
82 | #qsp-dropdown a:hover { |
|
86 | #qsp-dropdown a:hover { | |
83 | background-color: #ddd; |
|
87 | background-color: #ddd; | |
84 | } |
|
88 | } | |
|
89 | ||||
|
90 | /* Buttons */ | |||
|
91 | ||||
|
92 | .qsp-col3 a, .qsp-col3 img { | |||
|
93 | width: 50px; | |||
|
94 | height: 50px; | |||
|
95 | } | |||
|
96 | ||||
|
97 | #qsp-btn-save { | |||
|
98 | background: url('data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAADIAAAAyCAYAAAAeP4ixAAAABmJLR0QA/wD/AP+gvaeTAAACSklEQVRoge3ZPWgUQRjG8V/iRRFU/GoEQdSohSgWWqQSooVgK9iJFiKCnYV2BkFQsBRBQQwWVsHKIoWxEOzEwmhhogbRMhhFicTvYm+JCUlmZzabRLN/OPaWeZ+ZeW7feXf2lpqampqamnRaImKP4hA2VjCP27hbpoNGwbib2IPreB+IPYY7M7SvxWYM4QNO4QqWyQxVRgdeYnnB+K5A+wUcbB7z+O14hxPx08toLRDTgfv4mjrIJFrwwMS0HsABXMTxlE6LpNYqfE7pPJIBdOKhLM1uxIiLrpG5YtC4GSLMVGGkLdD+GpfxAuvxaVL7oCzN+jCG7iKDVmHkKS5hSSBuJ3bg6hRt+Zrpa553z8bEuoQrUVXk1exwKLBI1ZpPBnAL+0KBqanVim1Ykaifji+yNfIrVphipB1n8BgjCfqZ2IrTuIZXMcIUIydxFj8TtEW4JysW52JEKWtkVHUm4EdzjChSrkgLlmJXghb6m8ep9MN4K25XjvTF3sCaElrT6McS+0w2Mirb+JWhrH4CC/0+UpjUK7Ia5/86f4IeHMHeEvPJ+4km1chHE43k9KROpCyLPrViym8/vjW/b5Jt3acjL7/RzEX5bRg3sjKg+2fK7/PmZ9aZzdTqxwYzp06IBZFaDeHUCbFgUquy1Anx35TfRWXkd+WzCBOcQxEjQ7JH0PmiHW9CQUWM9Mr+Y+osO6ME8nF7Q4FFn8T2y14VDMt2vsFfqCRbZBvTdbLXFI9CgphHyjbsVu4+EcMInuH7HI1XU1NTU7OI+QMFe2N82rtssgAAAABJRU5ErkJggg=='); | |||
|
99 | } | |||
|
100 | ||||
|
101 | #qsp-btn-load { | |||
|
102 | background: url('data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAADIAAAAyCAYAAAAeP4ixAAAABmJLR0QA/wD/AP+gvaeTAAACCklEQVRoge3Yz6sNYRzH8deVexNxSaEoroWFUuomOceSPVnIwsbSxs6Psrgphf9AsrZR7kJWsroUlrZKKZRSl4USGouZk9Npzp1n5pm5x4/nXdNzpvP9Pp/v95nv82OGRCKRSCQS/w8zuIn3yGpe37CEQ6sedQk38BA7G/jO4BQ+YEebQZUxVfH/OxzGVSxX2D4o2mO4jmt4jpNFe6d5mPFkRbvQ0H9h6OqUtR33/xXr0celGn4/sYjXoQ5dJ3ILB7AOW2r4bcIj7GsrkEFpXWyrwwbaf15nXWqv6SqK1abuHDmPjV0EMobhBWIZt8cZVu0j2ZDNHF7gblRozdiO49g1zqDOEzmKJ7gcGVQTzmLDSgZ1Eunh2dD9aewpsXtctH3cwzn5ALysoVWlXZvhleMV5ovfU8J363mciAliRLsRg0Q244vfT3A/zgT2cQHbImIY1S4ldPk9Ii+NH8V9H08DfbfiY6BtiHYpoYmMBr4bbwN9YzfVoEELnew9+blpwBv5u0oI9wPtQrUbkWFaXqOzsZ01IFg7pLQOyp/A58igmhCsHZJInYndNsHa/0wiVWTy9/a5NjprQGvag0Qmwd462iGltdQ8lihqlVVIIn/9/CAvrajDWgTRB8VhMt1/aSljVr4RToc6hJTWioe1jujJD4rfQx2qRvuTyX1JuTIh3UQikUgkEhPnF+1xZ9hHnLjAAAAAAElFTkSuQmCC'); | |||
|
103 | } |
@@ -1,200 +1,210 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp) | |
3 |
|
3 | |||
4 | ;;; API deals with DOM manipulation and some bookkeeping for the |
|
4 | ;;; API deals with DOM manipulation and some bookkeeping for the | |
5 | ;;; intrinsics, namely variables |
|
5 | ;;; intrinsics, namely variables | |
6 | ;;; API is an implementation detail and has no QSP documentation. It |
|
6 | ;;; API is an implementation detail and has no QSP documentation. It | |
7 | ;;; doesn't call intrinsics |
|
7 | ;;; doesn't call intrinsics | |
8 |
|
8 | |||
9 | (setf (root api) (ps:create)) |
|
9 | (setf (root api) (ps:create)) | |
10 |
|
10 | |||
11 | ;;; Utils |
|
11 | ;;; Utils | |
12 |
|
12 | |||
13 | (defm (root api make-act-html) (title img) |
|
13 | (defm (root api make-act-html) (title img) | |
14 | (+ "<a class='qsp-act' href='#' onclick='SugarQSP.acts[\"" title "\"].act();'>" |
|
14 | (+ "<a class='qsp-act' href='#' onclick='SugarQSP.acts[\"" title "\"].act();'>" | |
15 | title |
|
15 | title | |
16 | "</a>")) |
|
16 | "</a>")) | |
17 |
|
17 | |||
18 | (defm (root api make-menu-item-html) (num title img loc) |
|
18 | (defm (root api make-menu-item-html) (num title img loc) | |
19 | (+ "<a href='#' onclick='SugarQSP.api.runMenu(" num ", \"" loc "\")();'>" |
|
19 | (+ "<a href='#' onclick='SugarQSP.api.runMenu(" num ", \"" loc "\")();'>" | |
20 | "<img src='" img "'>" |
|
20 | "<img src='" img "'>" | |
21 | title |
|
21 | title | |
22 | "</a>")) |
|
22 | "</a>")) | |
23 |
|
23 | |||
24 | ;; To be used in saving game |
|
24 | ;; To be used in saving game | |
25 | (defm (root api stash-state) () |
|
25 | (defm (root api stash-state) () | |
26 | (setf (root state-stash) |
|
26 | (setf (root state-stash) | |
27 | (*j-s-o-n.stringify |
|
27 | (*j-s-o-n.stringify | |
28 | (ps:create vars (root vars) |
|
28 | (ps:create vars (root vars) | |
29 | objs (root objs) |
|
29 | objs (root objs) | |
30 | next-location (root current-location)))) |
|
30 | next-location (root current-location)))) | |
31 | (values)) |
|
31 | (values)) | |
32 |
|
32 | |||
33 | (defm (root api state-to-base64) () |
|
33 | (defm (root api state-to-base64) () | |
34 | (btoa (encode-u-r-i-component (root state-stash)))) |
|
34 | (btoa (encode-u-r-i-component (root state-stash)))) | |
35 |
|
35 | |||
36 | (defm (root api base64-to-state) (data) |
|
36 | (defm (root api base64-to-state) (data) | |
37 | (setf (root state-stash) (decode-u-r-i-component (atob data))) |
|
37 | (setf (root state-stash) (decode-u-r-i-component (atob data))) | |
38 | (let ((data (*j-s-o-n.parse (root state-stash)))) |
|
38 | (let ((data (*j-s-o-n.parse (root state-stash)))) | |
|
39 | (api-call clear-id :qsp-main) | |||
|
40 | (api-call clear-id :qsp-stat) | |||
39 | (api-call clear-act) |
|
41 | (api-call clear-act) | |
40 | (setf (root vars) (ps:@ data vars)) |
|
42 | (setf (root vars) (ps:@ data vars)) | |
41 | (setf (root objs) (ps:@ data objs)) |
|
43 | (setf (root objs) (ps:@ data objs)) | |
42 | (setf (root current-location) (ps:@ data next-location)) |
|
44 | (setf (root current-location) (ps:@ data next-location)) | |
43 | (funcall (root locs (root current-location))) |
|
45 | (funcall (root locs (root current-location))) | |
44 | (api-call update-objs) |
|
46 | (api-call update-objs) | |
45 | (values))) |
|
47 | (values))) | |
46 |
|
48 | |||
47 | ;;; Misc |
|
49 | ;;; Misc | |
48 |
|
50 | |||
49 | (defm (root api clear-id) (id) |
|
51 | (defm (root api clear-id) (id) | |
50 | (setf (ps:chain document (get-element-by-id id) inner-text) "")) |
|
52 | (setf (ps:chain document (get-element-by-id id) inner-text) "")) | |
51 |
|
53 | |||
52 | (defm (root api get-id) (id) |
|
54 | (defm (root api get-id) (id) | |
53 | (if (var "USEHTML" 0) |
|
55 | (if (var "USEHTML" 0) | |
54 | (ps:chain (document.get-element-by-id id) inner-h-t-m-l) |
|
56 | (ps:chain (document.get-element-by-id id) inner-h-t-m-l) | |
55 | (ps:chain (document.get-element-by-id id) inner-text))) |
|
57 | (ps:chain (document.get-element-by-id id) inner-text))) | |
56 |
|
58 | |||
57 | (defm (root api set-id) (id contents) |
|
59 | (defm (root api set-id) (id contents) | |
58 | (if (var "USEHTML" 0) |
|
60 | (if (var "USEHTML" 0) | |
59 | (setf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents) |
|
61 | (setf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents) | |
60 | (setf (ps:chain (document.get-element-by-id id) inner-text) contents))) |
|
62 | (setf (ps:chain (document.get-element-by-id id) inner-text) contents))) | |
61 |
|
63 | |||
62 | (defm (root api append-id) (id contents) |
|
64 | (defm (root api append-id) (id contents) | |
63 | (if (var "USEHTML" 0) |
|
65 | (if (var "USEHTML" 0) | |
64 | (incf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents) |
|
66 | (incf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents) | |
65 | (incf (ps:chain (document.get-element-by-id id) inner-text) contents))) |
|
67 | (incf (ps:chain (document.get-element-by-id id) inner-text) contents))) | |
66 |
|
68 | |||
67 | ;;; Function calls |
|
69 | ;;; Function calls | |
68 |
|
70 | |||
69 | (defm (root api init-args) (args) |
|
71 | (defm (root api init-args) (args) | |
70 | (dotimes (i (length args)) |
|
72 | (dotimes (i (length args)) | |
71 | (if (numberp (elt args i)) |
|
73 | (if (numberp (elt args i)) | |
72 | (set (var args i) (elt args i)) |
|
74 | (set (var args i) (elt args i)) | |
73 | (set (var $args i) (elt args i))))) |
|
75 | (set (var $args i) (elt args i))))) | |
74 |
|
76 | |||
75 | (defm (root api get-result) () |
|
77 | (defm (root api get-result) () | |
76 | (if (not (equal "" (var $result 0))) |
|
78 | (if (not (equal "" (var $result 0))) | |
77 | (var $result 0) |
|
79 | (var $result 0) | |
78 | (var result 0))) |
|
80 | (var result 0))) | |
79 |
|
81 | |||
80 | ;;; Text windows |
|
82 | ;;; Text windows | |
81 |
|
83 | |||
82 | (defm (root api key-to-id) (key) |
|
84 | (defm (root api key-to-id) (key) | |
83 | (case key |
|
85 | (case key | |
84 | (:main "qsp-main") |
|
86 | (:main "qsp-main") | |
85 | (:stat "qsp-stat") |
|
87 | (:stat "qsp-stat") | |
86 | (:objs "qsp-objs") |
|
88 | (:objs "qsp-objs") | |
87 | (:acts "qsp-acts") |
|
89 | (:acts "qsp-acts") | |
88 | (:input "qsp-input") |
|
90 | (:input "qsp-input") | |
89 | (:dropdown "qsp-dropdown") |
|
91 | (:dropdown "qsp-dropdown") | |
90 | (t (report-error "Internal error!")))) |
|
92 | (t (report-error "Internal error!")))) | |
91 |
|
93 | |||
92 | (defm (root api get-frame) (key) |
|
94 | (defm (root api get-frame) (key) | |
93 | (document.get-element-by-id (api-call key-to-id key))) |
|
95 | (document.get-element-by-id (api-call key-to-id key))) | |
94 |
|
96 | |||
95 | (defm (root api add-text) (key text) |
|
97 | (defm (root api add-text) (key text) | |
96 | (api-call append-id (api-call key-to-id key) text)) |
|
98 | (api-call append-id (api-call key-to-id key) text)) | |
97 |
|
99 | |||
98 | (defm (root api get-text) (key) |
|
100 | (defm (root api get-text) (key) | |
99 | (api-call get-id (api-call key-to-id key))) |
|
101 | (api-call get-id (api-call key-to-id key))) | |
100 |
|
102 | |||
101 | (defm (root api clear-text) (key) |
|
103 | (defm (root api clear-text) (key) | |
102 | (api-call clear-id (api-call key-to-id key))) |
|
104 | (api-call clear-id (api-call key-to-id key))) | |
103 |
|
105 | |||
104 | (defm (root api newline) (key) |
|
106 | (defm (root api newline) (key) | |
105 | (let ((div (api-call get-frame key))) |
|
107 | (let ((div (api-call get-frame key))) | |
106 | (ps:chain div (append-child (document.create-element "br"))))) |
|
108 | (ps:chain div (append-child (document.create-element "br"))))) | |
107 |
|
109 | |||
108 | (defm (root api enable-frame) (key enable) |
|
110 | (defm (root api enable-frame) (key enable) | |
109 | (let ((clss (ps:getprop (api-call get-frame key) 'class-list))) |
|
111 | (let ((clss (ps:getprop (api-call get-frame key) 'class-list))) | |
110 | (setf clss.style.display (if enable "block" "none")) |
|
112 | (setf clss.style.display (if enable "block" "none")) | |
111 | (values))) |
|
113 | (values))) | |
112 |
|
114 | |||
113 | ;;; Actions |
|
115 | ;;; Actions | |
114 |
|
116 | |||
115 | (defm (root api add-act) (title img act) |
|
117 | (defm (root api add-act) (title img act) | |
116 | (setf (ps:getprop (root acts) title) |
|
118 | (setf (ps:getprop (root acts) title) | |
117 | (ps:create :img img :act act)) |
|
119 | (ps:create :img img :act act)) | |
118 | (api-call update-acts)) |
|
120 | (api-call update-acts)) | |
119 |
|
121 | |||
120 | (defm (root api del-act) (title) |
|
122 | (defm (root api del-act) (title) | |
121 | (delete (ps:getprop (root acts) title)) |
|
123 | (delete (ps:getprop (root acts) title)) | |
122 | (api-call update-acts)) |
|
124 | (api-call update-acts)) | |
123 |
|
125 | |||
124 | (defm (root api clear-act) () |
|
126 | (defm (root api clear-act) () | |
125 | (setf (root acts) (ps:create)) |
|
127 | (setf (root acts) (ps:create)) | |
126 | (api-call clear-id "qsp-acts")) |
|
128 | (api-call clear-id "qsp-acts")) | |
127 |
|
129 | |||
128 | (defm (root api update-acts) () |
|
130 | (defm (root api update-acts) () | |
129 | (api-call clear-id "qsp-acts") |
|
131 | (api-call clear-id "qsp-acts") | |
130 | (ps:for-in (title (root acts)) |
|
132 | (ps:for-in (title (root acts)) | |
131 | (let ((obj (ps:getprop (root acts) title))) |
|
133 | (let ((obj (ps:getprop (root acts) title))) | |
132 | (api-call append-id "qsp-acts" |
|
134 | (api-call append-id "qsp-acts" | |
133 | (api-call make-act-html title (ps:getprop obj :img)))))) |
|
135 | (api-call make-act-html title (ps:getprop obj :img)))))) | |
134 |
|
136 | |||
135 | ;;; Variables |
|
137 | ;;; Variables | |
136 |
|
138 | |||
137 | (defm (root api var-slot) (name) |
|
139 | (defm (root api var-slot) (name) | |
138 | (if (= (ps:@ name 0) #\$) |
|
140 | (if (= (ps:@ name 0) #\$) | |
139 | :str |
|
141 | :str | |
140 | :num)) |
|
142 | :num)) | |
141 |
|
143 | |||
142 | (defm (root api var-real-name) (name) |
|
144 | (defm (root api var-real-name) (name) | |
143 | (if (= (ps:@ name 0) #\$) |
|
145 | (if (= (ps:@ name 0) #\$) | |
144 | (ps:chain name (substr 1)) |
|
146 | (ps:chain name (substr 1)) | |
145 | name)) |
|
147 | name)) | |
146 |
|
148 | |||
147 | (defm (root api ensure-var) (name index) |
|
149 | (defm (root api ensure-var) (name index) | |
148 | (unless (in name (root vars)) |
|
150 | (unless (in name (root vars)) | |
149 | (setf (ps:getprop (root vars) name) |
|
151 | (setf (ps:getprop (root vars) name) | |
150 | (ps:create))) |
|
152 | (ps:create))) | |
151 | (unless (in index (ps:getprop (root vars) name)) |
|
153 | (unless (in index (ps:getprop (root vars) name)) | |
152 | (setf (ps:getprop (root vars) name index) |
|
154 | (setf (ps:getprop (root vars) name index) | |
153 | (ps:create :num 0 :str ""))) |
|
155 | (ps:create :num 0 :str ""))) | |
154 | (values)) |
|
156 | (values)) | |
155 |
|
157 | |||
156 | (defm (root api get-var) (name index) |
|
158 | (defm (root api get-var) (name index) | |
157 | (let ((var-name (api-call var-real-name name))) |
|
159 | (let ((var-name (api-call var-real-name name))) | |
158 | (api-call ensure-var var-name index) |
|
160 | (api-call ensure-var var-name index) | |
159 | (ps:getprop (root vars) var-name index |
|
161 | (ps:getprop (root vars) var-name index | |
160 | (api-call var-slot name)))) |
|
162 | (api-call var-slot name)))) | |
161 |
|
163 | |||
162 | (defm (root api set-var) (name index value) |
|
164 | (defm (root api set-var) (name index value) | |
163 | (let ((var-name (api-call var-real-name name))) |
|
165 | (let ((var-name (api-call var-real-name name))) | |
164 | (api-call ensure-var var-name index) |
|
166 | (api-call ensure-var var-name index) | |
165 | (setf (ps:getprop (root vars) var-name index |
|
167 | (setf (ps:getprop (root vars) var-name index | |
166 | (api-call var-slot name)) |
|
168 | (api-call var-slot name)) | |
167 | value) |
|
169 | value) | |
168 | (values))) |
|
170 | (values))) | |
169 |
|
171 | |||
170 | (defm (root api get-array) (name type) |
|
172 | (defm (root api get-array) (name type) | |
171 | (ps:getprop (root vars) (api-call var-real-name name))) |
|
173 | (ps:getprop (root vars) (api-call var-real-name name))) | |
172 |
|
174 | |||
173 | (defm (root api kill-var) (name index) |
|
175 | (defm (root api kill-var) (name index) | |
174 | (if (eq index :whole) |
|
176 | (if (eq index :whole) | |
175 | (ps:delete (ps:getprop (root vars) name)) |
|
177 | (ps:delete (ps:getprop (root vars) name)) | |
176 | (ps:delete (ps:getprop (root vars) name index))) |
|
178 | (ps:delete (ps:getprop (root vars) name index))) | |
177 | (values)) |
|
179 | (values)) | |
178 |
|
180 | |||
179 | (defm (root api array-size) (name) |
|
181 | (defm (root api array-size) (name) | |
180 | (ps:getprop (root vars) (api-call var-real-name name) 'length)) |
|
182 | (ps:getprop (root vars) (api-call var-real-name name) 'length)) | |
181 |
|
183 | |||
182 | ;;; Objects |
|
184 | ;;; Objects | |
183 |
|
185 | |||
184 | (defm (root api update-objs) () |
|
186 | (defm (root api update-objs) () | |
185 | (let ((elt (document.get-element-by-id "qsp-objs"))) |
|
187 | (let ((elt (document.get-element-by-id "qsp-objs"))) | |
186 | (setf elt.inner-h-t-m-l "<ul>") |
|
188 | (setf elt.inner-h-t-m-l "<ul>") | |
187 | (loop :for obj :in (root objs) |
|
189 | (loop :for obj :in (root objs) | |
188 | :do (incf elt.inner-h-t-m-l (+ "<li>" obj))) |
|
190 | :do (incf elt.inner-h-t-m-l (+ "<li>" obj))) | |
189 | (incf elt.inner-h-t-m-l "</ul>"))) |
|
191 | (incf elt.inner-h-t-m-l "</ul>"))) | |
190 |
|
192 | |||
191 | ;;; Menu |
|
193 | ;;; Menu | |
192 |
|
194 | |||
193 | (defm (root api menu) (menu-data) |
|
195 | (defm (root api menu) (menu-data) | |
194 | (let ((elt (document.get-element-by-id "qsp-dropdown")) |
|
196 | (let ((elt (document.get-element-by-id "qsp-dropdown")) | |
195 | (i 0)) |
|
197 | (i 0)) | |
196 | (setf elt.inner-h-t-m-l "") |
|
198 | (setf elt.inner-h-t-m-l "") | |
197 | (loop :for item :in menu-data |
|
199 | (loop :for item :in menu-data | |
198 | :do (incf i) |
|
200 | :do (incf i) | |
199 | :do (incf elt.inner-h-t-m-l (api-call make-menu-item-html i item.text item.icon item.loc))) |
|
201 | :do (incf elt.inner-h-t-m-l (api-call make-menu-item-html i item.text item.icon item.loc))) | |
200 | (setf elt.style.display "block"))) |
|
202 | (setf elt.style.display "block"))) | |
|
203 | ||||
|
204 | ;;; Content | |||
|
205 | ||||
|
206 | (defm (root api clean-audio) () | |||
|
207 | (loop :for k :in (*object.keys (root playing)) | |||
|
208 | :for v := (ps:getprop (root playing) k) | |||
|
209 | :do (when (ps:@ v ended) | |||
|
210 | (ps:delete (ps:@ (root playing) k))))) |
@@ -1,137 +1,140 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp) | |
3 |
|
3 | |||
4 | ;;;; Macros implementing some intrinsics where it makes sense |
|
4 | ;;;; Macros implementing some intrinsics where it makes sense | |
5 | ;;;; E.g. an equivalent JS function exists, or it's a direct API call |
|
5 | ;;;; E.g. an equivalent JS function exists, or it's a direct API call | |
6 |
|
6 | |||
7 | ;;; 1loc |
|
7 | ;;; 1loc | |
8 |
|
8 | |||
9 | ;;; 2var |
|
9 | ;;; 2var | |
10 |
|
10 | |||
11 | (ps:defpsmacro killvar (varname &optional (index :whole)) |
|
11 | (ps:defpsmacro killvar (varname &optional (index :whole)) | |
12 | `(api-call kill-var ,varname ,index)) |
|
12 | `(api-call kill-var ,varname ,index)) | |
13 |
|
13 | |||
14 | (ps:defpsmacro killall () |
|
14 | (ps:defpsmacro killall () | |
15 | `(api-call kill-all)) |
|
15 | `(api-call kill-all)) | |
16 |
|
16 | |||
17 | ;;; 3expr |
|
17 | ;;; 3expr | |
18 |
|
18 | |||
19 | (ps:defpsmacro obj (name) |
|
19 | (ps:defpsmacro obj (name) | |
20 | `(funcall (root objs includes) ,name)) |
|
20 | `(funcall (root objs includes) ,name)) | |
21 |
|
21 | |||
22 | (ps:defpsmacro loc (name) |
|
22 | (ps:defpsmacro loc (name) | |
23 | `(funcall (root locs includes) ,name)) |
|
23 | `(funcall (root locs includes) ,name)) | |
24 |
|
24 | |||
25 | (ps:defpsmacro no (arg) |
|
25 | (ps:defpsmacro no (arg) | |
26 | `(- -1 ,arg)) |
|
26 | `(- -1 ,arg)) | |
27 |
|
27 | |||
28 | ;;; 4code |
|
28 | ;;; 4code | |
29 |
|
29 | |||
30 | (ps:defpsmacro qspver () |
|
30 | (ps:defpsmacro qspver () | |
31 | "0.0.1") |
|
31 | "0.0.1") | |
32 |
|
32 | |||
33 | (ps:defpsmacro curloc () |
|
33 | (ps:defpsmacro curloc () | |
34 | `(root current-location)) |
|
34 | `(root current-location)) | |
35 |
|
35 | |||
36 | (ps:defpsmacro rnd () |
|
36 | (ps:defpsmacro rnd () | |
37 | `(funcall (root lib rand) 1 1000)) |
|
37 | `(funcall (root lib rand) 1 1000)) | |
38 |
|
38 | |||
39 | (ps:defpsmacro qspmax (&rest args) |
|
39 | (ps:defpsmacro qspmax (&rest args) | |
40 | `(max ,@args)) |
|
40 | `(max ,@args)) | |
41 |
|
41 | |||
42 | (ps:defpsmacro qspmin (&rest args) |
|
42 | (ps:defpsmacro qspmin (&rest args) | |
43 | `(min ,@args)) |
|
43 | `(min ,@args)) | |
44 |
|
44 | |||
45 | ;;; 5arrays |
|
45 | ;;; 5arrays | |
46 |
|
46 | |||
47 | (ps:defpsmacro arrsize (name) |
|
47 | (ps:defpsmacro arrsize (name) | |
48 | `(api-call array-size ,name)) |
|
48 | `(api-call array-size ,name)) | |
49 |
|
49 | |||
50 | ;;; 6str |
|
50 | ;;; 6str | |
51 |
|
51 | |||
52 | (ps:defpsmacro len (s) |
|
52 | (ps:defpsmacro len (s) | |
53 | `(length ,s)) |
|
53 | `(length ,s)) | |
54 |
|
54 | |||
55 | (ps:defpsmacro mid (s from &optional count) |
|
55 | (ps:defpsmacro mid (s from &optional count) | |
56 | `(ps:chain ,s (substring ,from ,count))) |
|
56 | `(ps:chain ,s (substring ,from ,count))) | |
57 |
|
57 | |||
58 | (ps:defpsmacro ucase (s) |
|
58 | (ps:defpsmacro ucase (s) | |
59 | `(ps:chain ,s (to-upper-case))) |
|
59 | `(ps:chain ,s (to-upper-case))) | |
60 |
|
60 | |||
61 | (ps:defpsmacro lcase (s) |
|
61 | (ps:defpsmacro lcase (s) | |
62 | `(ps:chain ,s (to-lower-case))) |
|
62 | `(ps:chain ,s (to-lower-case))) | |
63 |
|
63 | |||
64 | (ps:defpsmacro trim (s) |
|
64 | (ps:defpsmacro trim (s) | |
65 | `(ps:chain ,s (trim))) |
|
65 | `(ps:chain ,s (trim))) | |
66 |
|
66 | |||
67 | (ps:defpsmacro replace (s from to) |
|
67 | (ps:defpsmacro replace (s from to) | |
68 | `(ps:chain ,s (replace ,from ,to))) |
|
68 | `(ps:chain ,s (replace ,from ,to))) | |
69 |
|
69 | |||
70 | (ps:defpsmacro val (s) |
|
70 | (ps:defpsmacro val (s) | |
71 | `(parse-int ,s 10)) |
|
71 | `(parse-int ,s 10)) | |
72 |
|
72 | |||
73 | (ps:defpsmacro qspstr (n) |
|
73 | (ps:defpsmacro qspstr (n) | |
74 | `(ps:chain ,n (to-string))) |
|
74 | `(ps:chain ,n (to-string))) | |
75 |
|
75 | |||
76 | ;;; 7if |
|
76 | ;;; 7if | |
77 |
|
77 | |||
78 | ;;; 8sub |
|
78 | ;;; 8sub | |
79 |
|
79 | |||
80 | ;;; 9loops |
|
80 | ;;; 9loops | |
81 |
|
81 | |||
82 | ;; JUMP is in ps-macros.lisp (because it's a part of a huge kludge) |
|
82 | ;; JUMP is in ps-macros.lisp (because it's a part of a huge kludge) | |
83 |
|
83 | |||
84 | (ps:defpsmacro exit () |
|
84 | (ps:defpsmacro exit () | |
85 | `(return-from nil (values))) |
|
85 | `(return-from nil (values))) | |
86 |
|
86 | |||
87 | ;;; 10dynamic |
|
87 | ;;; 10dynamic | |
88 |
|
88 | |||
89 | ;;; 11main |
|
89 | ;;; 11main | |
90 |
|
90 | |||
91 | (ps:defpsmacro desc (s) |
|
91 | (ps:defpsmacro desc (s) | |
92 | (declare (ignore s)) |
|
92 | (declare (ignore s)) | |
93 | "") |
|
93 | "") | |
94 |
|
94 | |||
95 | ;;; 12stat |
|
95 | ;;; 12stat | |
96 |
|
96 | |||
97 | (ps:defpsmacro showstat (enable) |
|
97 | (ps:defpsmacro showstat (enable) | |
98 | `(api-call enable-frame :stat ,enable)) |
|
98 | `(api-call enable-frame :stat ,enable)) | |
99 |
|
99 | |||
100 | ;;; 13diag |
|
100 | ;;; 13diag | |
101 |
|
101 | |||
102 | (ps:defpsmacro msg (text) |
|
102 | (ps:defpsmacro msg (text) | |
103 | `(alert ,text)) |
|
103 | `(alert ,text)) | |
104 |
|
104 | |||
105 | ;;; 14act |
|
105 | ;;; 14act | |
106 |
|
106 | |||
107 | (ps:defpsmacro showacts (enable) |
|
107 | (ps:defpsmacro showacts (enable) | |
108 | `(api-call enable-frame :acts ,enable)) |
|
108 | `(api-call enable-frame :acts ,enable)) | |
109 |
|
109 | |||
110 | (ps:defpsmacro delact (name) |
|
110 | (ps:defpsmacro delact (name) | |
111 | `(api-call del-act ,name)) |
|
111 | `(api-call del-act ,name)) | |
112 |
|
112 | |||
113 | (ps:defpsmacro cla () |
|
113 | (ps:defpsmacro cla () | |
114 | `(api-call clear-act)) |
|
114 | `(api-call clear-act)) | |
115 |
|
115 | |||
116 | ;;; 15objs |
|
116 | ;;; 15objs | |
117 |
|
117 | |||
118 | (ps:defpsmacro showobjs (enable) |
|
118 | (ps:defpsmacro showobjs (enable) | |
119 | `(api-call enable-frame :objs ,enable)) |
|
119 | `(api-call enable-frame :objs ,enable)) | |
120 |
|
120 | |||
121 | (ps:defpsmacro countobj () |
|
121 | (ps:defpsmacro countobj () | |
122 | `(length (root objs))) |
|
122 | `(length (root objs))) | |
123 |
|
123 | |||
124 | (ps:defpsmacro getobj (index) |
|
124 | (ps:defpsmacro getobj (index) | |
125 | `(or (elt (root objs) ,index) "")) |
|
125 | `(or (elt (root objs) ,index) "")) | |
126 |
|
126 | |||
127 | ;;; 16menu |
|
127 | ;;; 16menu | |
128 |
|
128 | |||
129 | ;;; 17sound |
|
129 | ;;; 17sound | |
130 |
|
130 | |||
|
131 | (ps:defpsmacro isplay (filename) | |||
|
132 | `(funcall (root playing includes) ,filename)) | |||
|
133 | ||||
131 | ;;; 18img |
|
134 | ;;; 18img | |
132 |
|
135 | |||
133 | ;;; 19input |
|
136 | ;;; 19input | |
134 |
|
137 | |||
135 | ;;; 20time |
|
138 | ;;; 20time | |
136 |
|
139 | |||
137 | ;;; misc |
|
140 | ;;; misc |
@@ -1,313 +1,321 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp) | |
3 |
|
3 | |||
4 | ;;;; Functions and procedures defined by the QSP language. |
|
4 | ;;;; Functions and procedures defined by the QSP language. | |
5 | ;;;; They can call api and deal with locations and other data directly. |
|
5 | ;;;; They can call api and deal with locations and other data directly. | |
6 | ;;;; Except vars. Use VAR and SET or GET-VAR and SET-VAR api calls. |
|
6 | ;;;; Except vars. Use VAR and SET or GET-VAR and SET-VAR api calls. | |
7 |
|
7 | |||
8 | (setf (root lib) (ps:create)) |
|
8 | (setf (root lib) (ps:create)) | |
9 |
|
9 | |||
10 | ;;; 1loc |
|
10 | ;;; 1loc | |
11 |
|
11 | |||
12 | (defm (root lib goto) (target &rest args) |
|
12 | (defm (root lib goto) (target &rest args) | |
13 | (api-call clear-text :main) |
|
13 | (api-call clear-text :main) | |
14 | (apply (root lib xgoto) target args)) |
|
14 | (apply (root lib xgoto) target args)) | |
15 |
|
15 | |||
16 | (defm (root lib xgoto) (target &rest args) |
|
16 | (defm (root lib xgoto) (target &rest args) | |
17 | (api-call clear-act) |
|
17 | (api-call clear-act) | |
18 | (api-call init-args args) |
|
18 | (api-call init-args args) | |
19 | (setf (root current-location) (ps:chain target (to-upper-case))) |
|
19 | (setf (root current-location) (ps:chain target (to-upper-case))) | |
20 | (api-call stash-state) |
|
20 | (api-call stash-state) | |
21 | (funcall (ps:getprop (root locs) (root current-location)))) |
|
21 | (funcall (ps:getprop (root locs) (root current-location)))) | |
22 |
|
22 | |||
23 | ;;; 2var |
|
23 | ;;; 2var | |
24 |
|
24 | |||
25 | ;;; 3expr |
|
25 | ;;; 3expr | |
26 |
|
26 | |||
27 | ;;; 4code |
|
27 | ;;; 4code | |
28 |
|
28 | |||
29 | (defm (root lib rand) (a &optional (b 1)) |
|
29 | (defm (root lib rand) (a &optional (b 1)) | |
30 | (let ((min (min a b)) |
|
30 | (let ((min (min a b)) | |
31 | (max (max a b))) |
|
31 | (max (max a b))) | |
32 | (+ min (ps:chain *math (random (- max min)))))) |
|
32 | (+ min (ps:chain *math (random (- max min)))))) | |
33 |
|
33 | |||
34 | ;;; 5arrays |
|
34 | ;;; 5arrays | |
35 |
|
35 | |||
36 | (defm (root lib copyarr) (to from start count) |
|
36 | (defm (root lib copyarr) (to from start count) | |
37 | (ps:for ((i start)) |
|
37 | (ps:for ((i start)) | |
38 | ((< i (min (api-call array-size from) |
|
38 | ((< i (min (api-call array-size from) | |
39 | (+ start count)))) |
|
39 | (+ start count)))) | |
40 | ((incf i)) |
|
40 | ((incf i)) | |
41 | (api-call set-var to (+ start i) |
|
41 | (api-call set-var to (+ start i) | |
42 | (api-call get-var from (+ start i))))) |
|
42 | (api-call get-var from (+ start i))))) | |
43 |
|
43 | |||
44 | (defm (root lib arrpos) (name value &optional (start 0)) |
|
44 | (defm (root lib arrpos) (name value &optional (start 0)) | |
45 | (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i)) |
|
45 | (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i)) | |
46 | (when (eq (api-call get-var name i) value) |
|
46 | (when (eq (api-call get-var name i) value) | |
47 | (return i))) |
|
47 | (return i))) | |
48 | -1) |
|
48 | -1) | |
49 |
|
49 | |||
50 | (defm (root lib arrcomp) (name pattern &optional (start 0)) |
|
50 | (defm (root lib arrcomp) (name pattern &optional (start 0)) | |
51 | (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i)) |
|
51 | (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i)) | |
52 | (when (funcall (ps:getprop (api-call get-var name i) 'match) pattern) |
|
52 | (when (funcall (ps:getprop (api-call get-var name i) 'match) pattern) | |
53 | (return i))) |
|
53 | (return i))) | |
54 | -1) |
|
54 | -1) | |
55 |
|
55 | |||
56 | ;;; 6str |
|
56 | ;;; 6str | |
57 |
|
57 | |||
58 | (defm (root lib instr) (s subs &optional (start 1)) |
|
58 | (defm (root lib instr) (s subs &optional (start 1)) | |
59 | (+ start (ps:chain s (substring (- start 1)) (search subs)))) |
|
59 | (+ start (ps:chain s (substring (- start 1)) (search subs)))) | |
60 |
|
60 | |||
61 | (defm (root lib isnum) (s) |
|
61 | (defm (root lib isnum) (s) | |
62 | (if (is-na-n s) |
|
62 | (if (is-na-n s) | |
63 | 0 |
|
63 | 0 | |
64 | -1)) |
|
64 | -1)) | |
65 |
|
65 | |||
66 | (defm (root lib strcomp) (s pattern) |
|
66 | (defm (root lib strcomp) (s pattern) | |
67 | (if (s.match pattern) |
|
67 | (if (s.match pattern) | |
68 | -1 |
|
68 | -1 | |
69 | 0)) |
|
69 | 0)) | |
70 |
|
70 | |||
71 | (defm (root lib strfind) (s pattern group) |
|
71 | (defm (root lib strfind) (s pattern group) | |
72 | (let* ((re (ps:new (*reg-exp pattern))) |
|
72 | (let* ((re (ps:new (*reg-exp pattern))) | |
73 | (match (re.exec s))) |
|
73 | (match (re.exec s))) | |
74 | (match.group group))) |
|
74 | (match.group group))) | |
75 |
|
75 | |||
76 | (defm (root lib strpos) (s pattern &optional (group 0)) |
|
76 | (defm (root lib strpos) (s pattern &optional (group 0)) | |
77 | (let* ((re (ps:new (*reg-exp pattern))) |
|
77 | (let* ((re (ps:new (*reg-exp pattern))) | |
78 | (match (re.exec s)) |
|
78 | (match (re.exec s)) | |
79 | (found (match.group group))) |
|
79 | (found (match.group group))) | |
80 | (if found |
|
80 | (if found | |
81 | (s.search found) |
|
81 | (s.search found) | |
82 | 0))) |
|
82 | 0))) | |
83 |
|
83 | |||
84 | ;;; 7if |
|
84 | ;;; 7if | |
85 |
|
85 | |||
86 | ;; Has to be a function because it always evaluates all three of its |
|
86 | ;; Has to be a function because it always evaluates all three of its | |
87 | ;; arguments |
|
87 | ;; arguments | |
88 | (defm (root lib iif) (cond-expr then-expr else-expr) |
|
88 | (defm (root lib iif) (cond-expr then-expr else-expr) | |
89 | (if cond-expr then-expr else-expr)) |
|
89 | (if cond-expr then-expr else-expr)) | |
90 |
|
90 | |||
91 | ;;; 8sub |
|
91 | ;;; 8sub | |
92 |
|
92 | |||
93 | (defm (root lib gosub) (target &rest args) |
|
93 | (defm (root lib gosub) (target &rest args) | |
94 | (conserving-vars (args result) |
|
94 | (conserving-vars (args result) | |
95 | (api-call init-args args) |
|
95 | (api-call init-args args) | |
96 | (funcall (ps:getprop (root locs) target)) |
|
96 | (funcall (ps:getprop (root locs) target)) | |
97 | (values))) |
|
97 | (values))) | |
98 |
|
98 | |||
99 | (defm (root lib func) (target &rest args) |
|
99 | (defm (root lib func) (target &rest args) | |
100 | (conserving-vars (args result) |
|
100 | (conserving-vars (args result) | |
101 | (api-call init-args args) |
|
101 | (api-call init-args args) | |
102 | (funcall (ps:getprop (root locs) target)) |
|
102 | (funcall (ps:getprop (root locs) target)) | |
103 | (api-call get-result))) |
|
103 | (api-call get-result))) | |
104 |
|
104 | |||
105 | ;;; 9loops |
|
105 | ;;; 9loops | |
106 |
|
106 | |||
107 | ;;; 10dynamic |
|
107 | ;;; 10dynamic | |
108 |
|
108 | |||
109 | (defm (root lib dyneval) (block &rest args) |
|
109 | (defm (root lib dyneval) (block &rest args) | |
110 | (conserving-vars (args result) |
|
110 | (conserving-vars (args result) | |
111 | (api-call init-args args) |
|
111 | (api-call init-args args) | |
112 | (funcall block) |
|
112 | (funcall block) | |
113 | (api-call get-result))) |
|
113 | (api-call get-result))) | |
114 |
|
114 | |||
115 | (defm (root lib dynamic) (&rest args) |
|
115 | (defm (root lib dynamic) (&rest args) | |
116 | (conserving-vars (args result) |
|
116 | (conserving-vars (args result) | |
117 | (api-call init-args args) |
|
117 | (api-call init-args args) | |
118 | (funcall block) |
|
118 | (funcall block) | |
119 | (values))) |
|
119 | (values))) | |
120 |
|
120 | |||
121 | ;;; 11main |
|
121 | ;;; 11main | |
122 |
|
122 | |||
123 | (defm (root lib main-p) (s) |
|
123 | (defm (root lib main-p) (s) | |
124 | (api-call add-text :main s) |
|
124 | (api-call add-text :main s) | |
125 | (values)) |
|
125 | (values)) | |
126 |
|
126 | |||
127 | (defm (root lib main-pl) (s) |
|
127 | (defm (root lib main-pl) (s) | |
128 | (api-call add-text :main s) |
|
128 | (api-call add-text :main s) | |
129 | (api-call newline :main) |
|
129 | (api-call newline :main) | |
130 | (values)) |
|
130 | (values)) | |
131 |
|
131 | |||
132 | (defm (root lib main-nl) (s) |
|
132 | (defm (root lib main-nl) (s) | |
133 | (api-call newline :main) |
|
133 | (api-call newline :main) | |
134 | (api-call add-text :main s) |
|
134 | (api-call add-text :main s) | |
135 | (values)) |
|
135 | (values)) | |
136 |
|
136 | |||
137 | (defm (root lib maintxt) (s) |
|
137 | (defm (root lib maintxt) (s) | |
138 | (api-call get-text :main) |
|
138 | (api-call get-text :main) | |
139 | (values)) |
|
139 | (values)) | |
140 |
|
140 | |||
141 | ;; For clarity (it leaves a lib.desc() call in JS) |
|
141 | ;; For clarity (it leaves a lib.desc() call in JS) | |
142 | (defm (root lib desc) (s) |
|
142 | (defm (root lib desc) (s) | |
143 | "") |
|
143 | "") | |
144 |
|
144 | |||
145 | (defm (root lib main-clear) () |
|
145 | (defm (root lib main-clear) () | |
146 | (api-call clear-text :main) |
|
146 | (api-call clear-text :main) | |
147 | (values)) |
|
147 | (values)) | |
148 |
|
148 | |||
149 | ;;; 12stat |
|
149 | ;;; 12stat | |
150 |
|
150 | |||
151 | (defm (root lib stat-p) (s) |
|
151 | (defm (root lib stat-p) (s) | |
152 | (api-call add-text :stat s) |
|
152 | (api-call add-text :stat s) | |
153 | (values)) |
|
153 | (values)) | |
154 |
|
154 | |||
155 | (defm (root lib stat-pl) (s) |
|
155 | (defm (root lib stat-pl) (s) | |
156 | (api-call add-text :stat s) |
|
156 | (api-call add-text :stat s) | |
157 | (api-call newline :stat) |
|
157 | (api-call newline :stat) | |
158 | (values)) |
|
158 | (values)) | |
159 |
|
159 | |||
160 | (defm (root lib stat-nl) (s) |
|
160 | (defm (root lib stat-nl) (s) | |
161 | (api-call newline :stat) |
|
161 | (api-call newline :stat) | |
162 | (api-call add-text :stat s) |
|
162 | (api-call add-text :stat s) | |
163 | (values)) |
|
163 | (values)) | |
164 |
|
164 | |||
165 | (defm (root lib stattxt) (s) |
|
165 | (defm (root lib stattxt) (s) | |
166 | (api-call get-text :stat) |
|
166 | (api-call get-text :stat) | |
167 | (values)) |
|
167 | (values)) | |
168 |
|
168 | |||
169 | (defm (root lib stat-clear) () |
|
169 | (defm (root lib stat-clear) () | |
170 | (api-call clear-text :stat) |
|
170 | (api-call clear-text :stat) | |
171 | (values)) |
|
171 | (values)) | |
172 |
|
172 | |||
173 | (defm (root lib cls) () |
|
173 | (defm (root lib cls) () | |
174 | (funcall (root lib stat-clear)) |
|
174 | (funcall (root lib stat-clear)) | |
175 | (funcall (root lib main-clear)) |
|
175 | (funcall (root lib main-clear)) | |
176 | (funcall (root lib cla)) |
|
176 | (funcall (root lib cla)) | |
177 | (funcall (root lib cmdclear)) |
|
177 | (funcall (root lib cmdclear)) | |
178 | (values)) |
|
178 | (values)) | |
179 |
|
179 | |||
180 | ;;; 13diag |
|
180 | ;;; 13diag | |
181 |
|
181 | |||
182 | ;;; 14act |
|
182 | ;;; 14act | |
183 |
|
183 | |||
184 | (defm (root lib curacts) () |
|
184 | (defm (root lib curacts) () | |
185 | (let ((acts (root acts))) |
|
185 | (let ((acts (root acts))) | |
186 | (lambda () |
|
186 | (lambda () | |
187 | (setf (root acts) acts) |
|
187 | (setf (root acts) acts) | |
188 | (values)))) |
|
188 | (values)))) | |
189 |
|
189 | |||
190 | ;;; 15objs |
|
190 | ;;; 15objs | |
191 |
|
191 | |||
192 | (defm (root lib addobj) (name) |
|
192 | (defm (root lib addobj) (name) | |
193 | (ps:chain (root objs) (push name)) |
|
193 | (ps:chain (root objs) (push name)) | |
194 | (api-call update-objs) |
|
194 | (api-call update-objs) | |
195 | (values)) |
|
195 | (values)) | |
196 |
|
196 | |||
197 | (defm (root lib delobj) (name) |
|
197 | (defm (root lib delobj) (name) | |
198 | (let ((index (ps:chain (root objs) (index-of name)))) |
|
198 | (let ((index (ps:chain (root objs) (index-of name)))) | |
199 | (when (> index -1) |
|
199 | (when (> index -1) | |
200 | (funcall (root lib killobj) index))) |
|
200 | (funcall (root lib killobj) (1+ index)))) | |
201 | (values)) |
|
201 | (values)) | |
202 |
|
202 | |||
203 | (defm (root lib killobj) (&optional num) |
|
203 | (defm (root lib killobj) (&optional (num nil)) | |
204 | (if num |
|
204 | (if (eq nil num) | |
205 |
( |
|
205 | (setf (root objs) (list)) | |
206 |
( |
|
206 | (ps:chain (root objs) (splice (1- num) 1))) | |
207 | (api-call update-objs) |
|
207 | (api-call update-objs) | |
208 | (values)) |
|
208 | (values)) | |
209 |
|
209 | |||
210 | ;;; 16menu |
|
210 | ;;; 16menu | |
211 |
|
211 | |||
212 | (defm (root lib menu) (menu-name) |
|
212 | (defm (root lib menu) (menu-name) | |
213 | (let ((menu-data (list))) |
|
213 | (let ((menu-data (list))) | |
214 | (loop :for item :in (api-call get-array menu-name) |
|
214 | (loop :for item :in (api-call get-array menu-name) | |
215 | :do (cond ((string= item "") |
|
215 | :do (cond ((string= item "") | |
216 | (break)) |
|
216 | (break)) | |
217 | ((string= item "-:-") |
|
217 | ((string= item "-:-") | |
218 | (ps:chain menu-data (push :delimiter))) |
|
218 | (ps:chain menu-data (push :delimiter))) | |
219 | (t |
|
219 | (t | |
220 | (let* ((tokens (ps:chain item (split ":")))) |
|
220 | (let* ((tokens (ps:chain item (split ":")))) | |
221 | (when (= (length tokens) 2) |
|
221 | (when (= (length tokens) 2) | |
222 | (tokens.push "")) |
|
222 | (tokens.push "")) | |
223 | (let* ((text (ps:chain tokens (splice 0 (- tokens.length 2)) (join ":"))) |
|
223 | (let* ((text (ps:chain tokens (splice 0 (- tokens.length 2)) (join ":"))) | |
224 | (loc (ps:getprop tokens (- tokens.length 2))) |
|
224 | (loc (ps:getprop tokens (- tokens.length 2))) | |
225 | (icon (ps:getprop tokens (- tokens.length 1)))) |
|
225 | (icon (ps:getprop tokens (- tokens.length 1)))) | |
226 | (ps:chain menu-data |
|
226 | (ps:chain menu-data | |
227 | (push (ps:create text text |
|
227 | (push (ps:create text text | |
228 | loc loc |
|
228 | loc loc | |
229 | icon icon)))))))) |
|
229 | icon icon)))))))) | |
230 | (api-call menu menu-data) |
|
230 | (api-call menu menu-data) | |
231 | (values))) |
|
231 | (values))) | |
232 |
|
232 | |||
233 | ;;; 17sound |
|
233 | ;;; 17sound | |
234 |
|
234 | |||
235 | (defm (root lib play) ()) |
|
235 | (defm (root lib play) (filename &optional (volume 100)) | |
236 |
|
236 | (let ((audio (ps:new (*audio filename)))) | ||
237 | (defm (root lib isplay) ()) |
|
237 | (setf (ps:getprop (root playing) filename) audio) | |
|
238 | (setf (ps:@ audio volume) (* volume 0.01)) | |||
|
239 | (ps:chain audio (play)))) | |||
238 |
|
240 | |||
239 |
(defm (root lib close) ( |
|
241 | (defm (root lib close) (filename) | |
|
242 | (funcall (root playing filename) stop) | |||
|
243 | (ps:delete (root playing filename))) | |||
240 |
|
244 | |||
241 |
(defm (root lib closeall) () |
|
245 | (defm (root lib closeall) () | |
|
246 | (loop :for k :in (*object.keys (root playing)) | |||
|
247 | :for v := (ps:getprop (root playing) k) | |||
|
248 | :do (funcall v stop)) | |||
|
249 | (setf (root playing) (ps:create))) | |||
242 |
|
250 | |||
243 | ;;; 18img |
|
251 | ;;; 18img | |
244 |
|
252 | |||
245 | (defm (root lib refint) ()) |
|
253 | (defm (root lib refint) ()) | |
246 |
|
254 | |||
247 | (defm (root lib view) ()) |
|
255 | (defm (root lib view) ()) | |
248 |
|
256 | |||
249 | ;;; 19input |
|
257 | ;;; 19input | |
250 |
|
258 | |||
251 | (defm (root lib showinput) ()) |
|
259 | (defm (root lib showinput) ()) | |
252 |
|
260 | |||
253 | (defm (root lib usertxt) ()) |
|
261 | (defm (root lib usertxt) ()) | |
254 |
|
262 | |||
255 | (defm (root lib cmdclear) ()) |
|
263 | (defm (root lib cmdclear) ()) | |
256 |
|
264 | |||
257 | (defm (root lib input) ()) |
|
265 | (defm (root lib input) ()) | |
258 |
|
266 | |||
259 | ;;; 20time |
|
267 | ;;; 20time | |
260 |
|
268 | |||
261 | ;; I wonder if there's a better solution than busy-wait |
|
269 | ;; I wonder if there's a better solution than busy-wait | |
262 | (defm (root lib wait) (msec) |
|
270 | (defm (root lib wait) (msec) | |
263 | (let* ((now (ps:new (*date))) |
|
271 | (let* ((now (ps:new (*date))) | |
264 | (exit-time (+ (funcall now.get-time) msec))) |
|
272 | (exit-time (+ (funcall now.get-time) msec))) | |
265 | (loop :while (< (funcall now.get-time) exit-time)))) |
|
273 | (loop :while (< (funcall now.get-time) exit-time)))) | |
266 |
|
274 | |||
267 | (defm (root lib msecscount) ()) |
|
275 | (defm (root lib msecscount) ()) | |
268 |
|
276 | |||
269 | (defm (root lib settimer) ()) |
|
277 | (defm (root lib settimer) ()) | |
270 |
|
278 | |||
271 | ;;; misc |
|
279 | ;;; misc | |
272 |
|
280 | |||
273 | (defm (root lib rgb) ()) |
|
281 | (defm (root lib rgb) ()) | |
274 |
|
282 | |||
275 | (defm (root lib openqst) ()) |
|
283 | (defm (root lib openqst) ()) | |
276 |
|
284 | |||
277 | (defm (root lib addqst) ()) |
|
285 | (defm (root lib addqst) ()) | |
278 |
|
286 | |||
279 | (defm (root lib killqst) ()) |
|
287 | (defm (root lib killqst) ()) | |
280 |
|
288 | |||
281 | (defm (root lib opengame) (&optional filename) |
|
289 | (defm (root lib opengame) (&optional filename) | |
282 | (let ((element (document.create-element :input))) |
|
290 | (let ((element (document.create-element :input))) | |
283 | (element.set-attribute :type :file) |
|
291 | (element.set-attribute :type :file) | |
284 | (element.set-attribute :id :qsp-opengame) |
|
292 | (element.set-attribute :id :qsp-opengame) | |
285 | (element.set-attribute :tabindex -1) |
|
293 | (element.set-attribute :tabindex -1) | |
286 | (element.set-attribute "aria-hidden" t) |
|
294 | (element.set-attribute "aria-hidden" t) | |
287 | (setf element.style.display :block) |
|
295 | (setf element.style.display :block) | |
288 | (setf element.style.visibility :hidden) |
|
296 | (setf element.style.visibility :hidden) | |
289 | (setf element.style.position :fixed) |
|
297 | (setf element.style.position :fixed) | |
290 | (setf element.onchange |
|
298 | (setf element.onchange | |
291 | (lambda (event) |
|
299 | (lambda (event) | |
292 | (let* ((file (elt event.target.files 0)) |
|
300 | (let* ((file (elt event.target.files 0)) | |
293 | (reader (ps:new (*file-reader)))) |
|
301 | (reader (ps:new (*file-reader)))) | |
294 | (setf reader.onload |
|
302 | (setf reader.onload | |
295 | (lambda (ev) |
|
303 | (lambda (ev) | |
296 | (block nil |
|
304 | (block nil | |
297 | (let ((target ev.current-target)) |
|
305 | (let ((target ev.current-target)) | |
298 | (unless target.result |
|
306 | (unless target.result | |
299 | (return)) |
|
307 | (return)) | |
300 | (api-call base64-to-state target.result))))) |
|
308 | (api-call base64-to-state target.result))))) | |
301 | (reader.read-as-text file)))) |
|
309 | (reader.read-as-text file)))) | |
302 | (document.body.append-child element) |
|
310 | (document.body.append-child element) | |
303 | (element.click) |
|
311 | (element.click) | |
304 | (document.body.remove-child element))) |
|
312 | (document.body.remove-child element))) | |
305 |
|
313 | |||
306 | (defm (root lib savegame) (&optional filename) |
|
314 | (defm (root lib savegame) (&optional filename) | |
307 | (let ((element (document.create-element :a))) |
|
315 | (let ((element (document.create-element :a))) | |
308 | (element.set-attribute :href (+ "data:text/plain;charset=utf-8," (api-call state-to-base64))) |
|
316 | (element.set-attribute :href (+ "data:text/plain;charset=utf-8," (api-call state-to-base64))) | |
309 | (element.set-attribute :download "savegame.sav") |
|
317 | (element.set-attribute :download "savegame.sav") | |
310 | (setf element.style.display :none) |
|
318 | (setf element.style.display :none) | |
311 | (document.body.append-child element) |
|
319 | (document.body.append-child element) | |
312 | (element.click) |
|
320 | (element.click) | |
313 | (document.body.remove-child element))) |
|
321 | (document.body.remove-child element))) |
@@ -1,21 +1,32 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp) | |
3 |
|
3 | |||
4 | (setf (root) |
|
4 | (setf (root) | |
5 |
( |
|
5 | (ps:create | |
|
6 | ;;; Game session state | |||
|
7 | ;; Variables | |||
|
8 | vars (ps:create) | |||
|
9 | ;; Inventory (objects) | |||
6 |
|
|
10 | objs (list) | |
|
11 | ;;; Transient state | |||
|
12 | ;; Savegame data | |||
7 |
|
|
13 | state-stash (ps:create) | |
|
14 | ;; List of audio files being played | |||
|
15 | playing (ps:create) | |||
|
16 | ;;; Game data | |||
|
17 | ;; ACTions | |||
8 |
|
|
18 | acts (ps:create) | |
|
19 | ;; Locations | |||
9 |
|
|
20 | locs (ps:create))) | |
10 |
|
21 | |||
11 | ;; Launch the game from the first location |
|
22 | ;; Launch the game from the first location | |
12 | (setf window.onload |
|
23 | (setf window.onload | |
13 | (lambda () |
|
24 | (lambda () | |
14 | (funcall (ps:getprop (root locs) |
|
25 | (funcall (ps:getprop (root locs) | |
15 | (ps:chain *object (keys (root locs)) 0))) |
|
26 | (ps:chain *object (keys (root locs)) 0))) | |
16 | (values))) |
|
27 | (values))) | |
17 |
|
28 | |||
18 | ;; Close the dropdown on any click |
|
29 | ;; Close the dropdown on any click | |
19 | (setf window.onclick |
|
30 | (setf window.onclick | |
20 | (lambda (event) |
|
31 | (lambda (event) | |
21 | (setf (ps:@ (api-call get-frame :dropdown) style display) "none"))) |
|
32 | (setf (ps:@ (api-call get-frame :dropdown) style display) "none"))) |
General Comments 0
You need to be logged in to leave comments.
Login now