" s endurl)
559 | (+ it 3)
560 | endurl)))
561 | (writec (s i))))
562 | (litmatch "" s i)
563 | (awhen (findsubseq "
" s (+ i 12))
564 | (pr (cut s (+ i 11) it))
565 | (= i (+ it 12)))
566 | (writec (s i))))))
567 |
568 |
569 | (def english-time (min)
570 | (let n (mod min 720)
571 | (string (let h (trunc (/ n 60)) (if (is h 0) "12" h))
572 | ":"
573 | (let m (mod n 60)
574 | (if (is m 0) "00"
575 | (< m 10) (string "0" m)
576 | m))
577 | (if (is min 0) " midnight"
578 | (is min 720) " noon"
579 | (>= min 720) " pm"
580 | " am"))))
581 |
582 | (def parse-time (s)
583 | (let (nums (o label "")) (halve s letter)
584 | (with ((h (o m 0)) (map int (tokens nums ~digit))
585 | cleanlabel (downcase (rem ~alphadig label)))
586 | (+ (* (if (is h 12)
587 | (if (in cleanlabel "am" "midnight")
588 | 0
589 | 12)
590 | (is cleanlabel "am")
591 | h
592 | (+ h 12))
593 | 60)
594 | m))))
595 |
596 |
597 | (= months* '("January" "February" "March" "April" "May" "June" "July"
598 | "August" "September" "October" "November" "December"))
599 |
600 | (def english-date ((y m d))
601 | (string d " " (months* (- m 1)) " " y))
602 |
603 | (= month-names* (obj "january" 1 "jan" 1
604 | "february" 2 "feb" 2
605 | "march" 3 "mar" 3
606 | "april" 4 "apr" 4
607 | "may" 5
608 | "june" 6 "jun" 6
609 | "july" 7 "jul" 7
610 | "august" 8 "aug" 8
611 | "september" 9 "sept" 9 "sep" 9
612 | "october" 10 "oct" 10
613 | "november" 11 "nov" 11
614 | "december" 12 "dec" 12))
615 |
616 | (def monthnum (s) (month-names* (downcase s)))
617 |
618 | ; Doesn't work for BC dates.
619 |
620 | (def parse-date (s)
621 | (let nums (date-nums s)
622 | (if (valid-date nums)
623 | nums
624 | (err (string "Invalid date: " s)))))
625 |
626 | (def date-nums (s)
627 | (with ((ynow mnow dnow) (date)
628 | toks (tokens s ~alphadig))
629 | (if (all [all digit _] toks)
630 | (let nums (map int toks)
631 | (case (len nums)
632 | 1 (list ynow mnow (car nums))
633 | 2 (iflet d (find [> _ 12] nums)
634 | (list ynow (find [isnt _ d] nums) d)
635 | (cons ynow nums))
636 | (if (> (car nums) 31)
637 | (firstn 3 nums)
638 | (rev (firstn 3 nums)))))
639 | ([all digit _] (car toks))
640 | (withs ((ds ms ys) toks
641 | d (int ds))
642 | (aif (monthnum ms)
643 | (list (or (errsafe (int ys)) ynow)
644 | it
645 | d)
646 | nil))
647 | (monthnum (car toks))
648 | (let (ms ds ys) toks
649 | (aif (errsafe (int ds))
650 | (list (or (errsafe (int ys)) ynow)
651 | (monthnum (car toks))
652 | it)
653 | nil))
654 | nil)))
655 |
656 | ; To be correct needs to know days per month, and about leap years
657 |
658 | (def valid-date ((y m d))
659 | (and y m d
660 | (< 0 m 13)
661 | (< 0 d 32)))
662 |
663 | (mac defopl (name parm . body)
664 | `(defop ,name ,parm
665 | (if (get-user ,parm)
666 | (do ,@body)
667 | (login-page 'both
668 | "You need to be logged in to do that."
669 | (list (fn (u ip))
670 | (string ',name (reassemble-args ,parm)))))))
671 |
672 |
--------------------------------------------------------------------------------
/arc3.1/arc.arc:
--------------------------------------------------------------------------------
1 | ; Main Arc lib. Ported to Scheme version Jul 06.
2 |
3 | ; don't like names of conswhen and consif
4 |
5 | ; need better way of generating strings; too many calls to string
6 | ; maybe strings with escape char for evaluation
7 | ; make foo~bar equiv of foo:~bar (in expand-ssyntax)
8 | ; add sigs of ops defined in ac.scm
9 | ; get hold of error types within arc
10 | ; does macex have to be defined in scheme instead of using def below?
11 | ; write disp, read, write in arc
12 | ; could I get all of macros up into arc.arc?
13 | ; warn when shadow a global name
14 | ; some simple regexp/parsing plan
15 |
16 | ; compromises in this implementation:
17 | ; no objs in code
18 | ; (mac testlit args (listtab args)) breaks when called
19 | ; separate string type
20 | ; (= (cdr (cdr str)) "foo") couldn't work because no way to get str tail
21 | ; not sure this is a mistake; strings may be subtly different from
22 | ; lists of chars
23 |
24 |
25 | (assign do (annotate 'mac
26 | (fn args `((fn () ,@args)))))
27 |
28 | (assign safeset (annotate 'mac
29 | (fn (var val)
30 | `(do (if (bound ',var)
31 | (do (disp "*** redefining " (stderr))
32 | (disp ',var (stderr))
33 | (disp #\newline (stderr))))
34 | (assign ,var ,val)))))
35 |
36 | (assign def (annotate 'mac
37 | (fn (name parms . body)
38 | `(do (sref sig ',parms ',name)
39 | (safeset ,name (fn ,parms ,@body))))))
40 |
41 | (def caar (xs) (car (car xs)))
42 | (def cadr (xs) (car (cdr xs)))
43 | (def cddr (xs) (cdr (cdr xs)))
44 |
45 | (def no (x) (is x nil))
46 |
47 | (def acons (x) (is (type x) 'cons))
48 |
49 | (def atom (x) (no (acons x)))
50 |
51 | ; Can return to this def once Rtm gets ac to make all rest args
52 | ; nil-terminated lists.
53 |
54 | ; (def list args args)
55 |
56 | (def copylist (xs)
57 | (if (no xs)
58 | nil
59 | (cons (car xs) (copylist (cdr xs)))))
60 |
61 | (def list args (copylist args))
62 |
63 | (def idfn (x) x)
64 |
65 | ; Maybe later make this internal. Useful to let xs be a fn?
66 |
67 | (def map1 (f xs)
68 | (if (no xs)
69 | nil
70 | (cons (f (car xs)) (map1 f (cdr xs)))))
71 |
72 | (def pair (xs (o f list))
73 | (if (no xs)
74 | nil
75 | (no (cdr xs))
76 | (list (list (car xs)))
77 | (cons (f (car xs) (cadr xs))
78 | (pair (cddr xs) f))))
79 |
80 | (assign mac (annotate 'mac
81 | (fn (name parms . body)
82 | `(do (sref sig ',parms ',name)
83 | (safeset ,name (annotate 'mac (fn ,parms ,@body)))))))
84 |
85 | (mac and args
86 | (if args
87 | (if (cdr args)
88 | `(if ,(car args) (and ,@(cdr args)))
89 | (car args))
90 | 't))
91 |
92 | (def assoc (key al)
93 | (if (atom al)
94 | nil
95 | (and (acons (car al)) (is (caar al) key))
96 | (car al)
97 | (assoc key (cdr al))))
98 |
99 | (def alref (al key) (cadr (assoc key al)))
100 |
101 | (mac with (parms . body)
102 | `((fn ,(map1 car (pair parms))
103 | ,@body)
104 | ,@(map1 cadr (pair parms))))
105 |
106 | (mac let (var val . body)
107 | `(with (,var ,val) ,@body))
108 |
109 | (mac withs (parms . body)
110 | (if (no parms)
111 | `(do ,@body)
112 | `(let ,(car parms) ,(cadr parms)
113 | (withs ,(cddr parms) ,@body))))
114 |
115 | ; Rtm prefers to overload + to do this
116 |
117 | (def join args
118 | (if (no args)
119 | nil
120 | (let a (car args)
121 | (if (no a)
122 | (apply join (cdr args))
123 | (cons (car a) (apply join (cdr a) (cdr args)))))))
124 |
125 | ; Need rfn for use in macro expansions.
126 |
127 | (mac rfn (name parms . body)
128 | `(let ,name nil
129 | (assign ,name (fn ,parms ,@body))))
130 |
131 | (mac afn (parms . body)
132 | `(let self nil
133 | (assign self (fn ,parms ,@body))))
134 |
135 | ; Ac expands x:y:z into (compose x y z), ~x into (complement x)
136 |
137 | ; Only used when the call to compose doesn't occur in functional position.
138 | ; Composes in functional position are transformed away by ac.
139 |
140 | (mac compose args
141 | (let g (uniq)
142 | `(fn ,g
143 | ,((afn (fs)
144 | (if (cdr fs)
145 | (list (car fs) (self (cdr fs)))
146 | `(apply ,(if (car fs) (car fs) 'idfn) ,g)))
147 | args))))
148 |
149 | ; Ditto: complement in functional position optimized by ac.
150 |
151 | (mac complement (f)
152 | (let g (uniq)
153 | `(fn ,g (no (apply ,f ,g)))))
154 |
155 | (def rev (xs)
156 | ((afn (xs acc)
157 | (if (no xs)
158 | acc
159 | (self (cdr xs) (cons (car xs) acc))))
160 | xs nil))
161 |
162 | (def isnt (x y) (no (is x y)))
163 |
164 | (mac w/uniq (names . body)
165 | (if (acons names)
166 | `(with ,(apply + nil (map1 (fn (n) (list n '(uniq)))
167 | names))
168 | ,@body)
169 | `(let ,names (uniq) ,@body)))
170 |
171 | (mac or args
172 | (and args
173 | (w/uniq g
174 | `(let ,g ,(car args)
175 | (if ,g ,g (or ,@(cdr args)))))))
176 |
177 | (def alist (x) (or (no x) (is (type x) 'cons)))
178 |
179 | (mac in (x . choices)
180 | (w/uniq g
181 | `(let ,g ,x
182 | (or ,@(map1 (fn (c) `(is ,g ,c)) choices)))))
183 |
184 | ; Could take n args, but have never once needed that.
185 |
186 | (def iso (x y)
187 | (or (is x y)
188 | (and (acons x)
189 | (acons y)
190 | (iso (car x) (car y))
191 | (iso (cdr x) (cdr y)))))
192 |
193 | (mac when (test . body)
194 | `(if ,test (do ,@body)))
195 |
196 | (mac unless (test . body)
197 | `(if (no ,test) (do ,@body)))
198 |
199 | (mac while (test . body)
200 | (w/uniq (gf gp)
201 | `((rfn ,gf (,gp)
202 | (when ,gp ,@body (,gf ,test)))
203 | ,test)))
204 |
205 | (def empty (seq)
206 | (or (no seq)
207 | (and (or (is (type seq) 'string) (is (type seq) 'table))
208 | (is (len seq) 0))))
209 |
210 | (def reclist (f xs)
211 | (and xs (or (f xs) (reclist f (cdr xs)))))
212 |
213 | (def recstring (test s (o start 0))
214 | ((afn (i)
215 | (and (< i (len s))
216 | (or (test i)
217 | (self (+ i 1)))))
218 | start))
219 |
220 | (def testify (x)
221 | (if (isa x 'fn) x [is _ x]))
222 |
223 | ; Like keep, seems like some shouldn't testify. But find should,
224 | ; and all probably should.
225 |
226 | (def some (test seq)
227 | (let f (testify test)
228 | (if (alist seq)
229 | (reclist f:car seq)
230 | (recstring f:seq seq))))
231 |
232 | (def all (test seq)
233 | (~some (complement (testify test)) seq))
234 |
235 | (def mem (test seq)
236 | (let f (testify test)
237 | (reclist [if (f:car _) _] seq)))
238 |
239 | (def find (test seq)
240 | (let f (testify test)
241 | (if (alist seq)
242 | (reclist [if (f:car _) (car _)] seq)
243 | (recstring [if (f:seq _) (seq _)] seq))))
244 |
245 | (def isa (x y) (is (type x) y))
246 |
247 | ; Possible to write map without map1, but makes News 3x slower.
248 |
249 | ;(def map (f . seqs)
250 | ; (if (some1 no seqs)
251 | ; nil
252 | ; (no (cdr seqs))
253 | ; (let s1 (car seqs)
254 | ; (cons (f (car s1))
255 | ; (map f (cdr s1))))
256 | ; (cons (apply f (map car seqs))
257 | ; (apply map f (map cdr seqs)))))
258 |
259 |
260 | (def map (f . seqs)
261 | (if (some [isa _ 'string] seqs)
262 | (withs (n (apply min (map len seqs))
263 | new (newstring n))
264 | ((afn (i)
265 | (if (is i n)
266 | new
267 | (do (sref new (apply f (map [_ i] seqs)) i)
268 | (self (+ i 1)))))
269 | 0))
270 | (no (cdr seqs))
271 | (map1 f (car seqs))
272 | ((afn (seqs)
273 | (if (some no seqs)
274 | nil
275 | (cons (apply f (map1 car seqs))
276 | (self (map1 cdr seqs)))))
277 | seqs)))
278 |
279 | (def mappend (f . args)
280 | (apply + nil (apply map f args)))
281 |
282 | (def firstn (n xs)
283 | (if (no n) xs
284 | (and (> n 0) xs) (cons (car xs) (firstn (- n 1) (cdr xs)))
285 | nil))
286 |
287 | (def nthcdr (n xs)
288 | (if (no n) xs
289 | (> n 0) (nthcdr (- n 1) (cdr xs))
290 | xs))
291 |
292 | ; Generalization of pair: (tuples x) = (pair x)
293 |
294 | (def tuples (xs (o n 2))
295 | (if (no xs)
296 | nil
297 | (cons (firstn n xs)
298 | (tuples (nthcdr n xs) n))))
299 |
300 | ; If ok to do with =, why not with def? But see if use it.
301 |
302 | (mac defs args
303 | `(do ,@(map [cons 'def _] (tuples args 3))))
304 |
305 | (def caris (x val)
306 | (and (acons x) (is (car x) val)))
307 |
308 | (def warn (msg . args)
309 | (disp (+ "Warning: " msg ". "))
310 | (map [do (write _) (disp " ")] args)
311 | (disp #\newline))
312 |
313 | (mac atomic body
314 | `(atomic-invoke (fn () ,@body)))
315 |
316 | (mac atlet args
317 | `(atomic (let ,@args)))
318 |
319 | (mac atwith args
320 | `(atomic (with ,@args)))
321 |
322 | (mac atwiths args
323 | `(atomic (withs ,@args)))
324 |
325 |
326 | ; setforms returns (vars get set) for a place based on car of an expr
327 | ; vars is a list of gensyms alternating with expressions whose vals they
328 | ; should be bound to, suitable for use as first arg to withs
329 | ; get is an expression returning the current value in the place
330 | ; set is an expression representing a function of one argument
331 | ; that stores a new value in the place
332 |
333 | ; A bit gross that it works based on the *name* in the car, but maybe
334 | ; wrong to worry. Macros live in expression land.
335 |
336 | ; seems meaningful to e.g. (push 1 (pop x)) if (car x) is a cons.
337 | ; can't in cl though. could I define a setter for push or pop?
338 |
339 | (assign setter (table))
340 |
341 | (mac defset (name parms . body)
342 | (w/uniq gexpr
343 | `(sref setter
344 | (fn (,gexpr)
345 | (let ,parms (cdr ,gexpr)
346 | ,@body))
347 | ',name)))
348 |
349 | (defset car (x)
350 | (w/uniq g
351 | (list (list g x)
352 | `(car ,g)
353 | `(fn (val) (scar ,g val)))))
354 |
355 | (defset cdr (x)
356 | (w/uniq g
357 | (list (list g x)
358 | `(cdr ,g)
359 | `(fn (val) (scdr ,g val)))))
360 |
361 | (defset caar (x)
362 | (w/uniq g
363 | (list (list g x)
364 | `(caar ,g)
365 | `(fn (val) (scar (car ,g) val)))))
366 |
367 | (defset cadr (x)
368 | (w/uniq g
369 | (list (list g x)
370 | `(cadr ,g)
371 | `(fn (val) (scar (cdr ,g) val)))))
372 |
373 | (defset cddr (x)
374 | (w/uniq g
375 | (list (list g x)
376 | `(cddr ,g)
377 | `(fn (val) (scdr (cdr ,g) val)))))
378 |
379 | ; Note: if expr0 macroexpands into any expression whose car doesn't
380 | ; have a setter, setforms assumes it's a data structure in functional
381 | ; position. Such bugs will be seen only when the code is executed, when
382 | ; sref complains it can't set a reference to a function.
383 |
384 | (def setforms (expr0)
385 | (let expr (macex expr0)
386 | (if (isa expr 'sym)
387 | (if (ssyntax expr)
388 | (setforms (ssexpand expr))
389 | (w/uniq (g h)
390 | (list (list g expr)
391 | g
392 | `(fn (,h) (assign ,expr ,h)))))
393 | ; make it also work for uncompressed calls to compose
394 | (and (acons expr) (metafn (car expr)))
395 | (setforms (expand-metafn-call (ssexpand (car expr)) (cdr expr)))
396 | (and (acons expr) (acons (car expr)) (is (caar expr) 'get))
397 | (setforms (list (cadr expr) (cadr (car expr))))
398 | (let f (setter (car expr))
399 | (if f
400 | (f expr)
401 | ; assumed to be data structure in fn position
402 | (do (when (caris (car expr) 'fn)
403 | (warn "Inverting what looks like a function call"
404 | expr0 expr))
405 | (w/uniq (g h)
406 | (let argsyms (map [uniq] (cdr expr))
407 | (list (+ (list g (car expr))
408 | (mappend list argsyms (cdr expr)))
409 | `(,g ,@argsyms)
410 | `(fn (,h) (sref ,g ,h ,(car argsyms))))))))))))
411 |
412 | (def metafn (x)
413 | (or (ssyntax x)
414 | (and (acons x) (in (car x) 'compose 'complement))))
415 |
416 | (def expand-metafn-call (f args)
417 | (if (is (car f) 'compose)
418 | ((afn (fs)
419 | (if (caris (car fs) 'compose) ; nested compose
420 | (self (join (cdr (car fs)) (cdr fs)))
421 | (cdr fs)
422 | (list (car fs) (self (cdr fs)))
423 | (cons (car fs) args)))
424 | (cdr f))
425 | (is (car f) 'no)
426 | (err "Can't invert " (cons f args))
427 | (cons f args)))
428 |
429 | (def expand= (place val)
430 | (if (and (isa place 'sym) (~ssyntax place))
431 | `(assign ,place ,val)
432 | (let (vars prev setter) (setforms place)
433 | (w/uniq g
434 | `(atwith ,(+ vars (list g val))
435 | (,setter ,g))))))
436 |
437 | (def expand=list (terms)
438 | `(do ,@(map (fn ((p v)) (expand= p v)) ; [apply expand= _]
439 | (pair terms))))
440 |
441 | (mac = args
442 | (expand=list args))
443 |
444 | (mac loop (start test update . body)
445 | (w/uniq (gfn gparm)
446 | `(do ,start
447 | ((rfn ,gfn (,gparm)
448 | (if ,gparm
449 | (do ,@body ,update (,gfn ,test))))
450 | ,test))))
451 |
452 | (mac for (v init max . body)
453 | (w/uniq (gi gm)
454 | `(with (,v nil ,gi ,init ,gm (+ ,max 1))
455 | (loop (assign ,v ,gi) (< ,v ,gm) (assign ,v (+ ,v 1))
456 | ,@body))))
457 |
458 | (mac down (v init min . body)
459 | (w/uniq (gi gm)
460 | `(with (,v nil ,gi ,init ,gm (- ,min 1))
461 | (loop (assign ,v ,gi) (> ,v ,gm) (assign ,v (- ,v 1))
462 | ,@body))))
463 |
464 | (mac repeat (n . body)
465 | `(for ,(uniq) 1 ,n ,@body))
466 |
467 | ; could bind index instead of gensym
468 |
469 | (mac each (var expr . body)
470 | (w/uniq (gseq gf gv)
471 | `(let ,gseq ,expr
472 | (if (alist ,gseq)
473 | ((rfn ,gf (,gv)
474 | (when (acons ,gv)
475 | (let ,var (car ,gv) ,@body)
476 | (,gf (cdr ,gv))))
477 | ,gseq)
478 | (isa ,gseq 'table)
479 | (maptable (fn ,var ,@body)
480 | ,gseq)
481 | (for ,gv 0 (- (len ,gseq) 1)
482 | (let ,var (,gseq ,gv) ,@body))))))
483 |
484 | ; (nthcdr x y) = (cut y x).
485 |
486 | (def cut (seq start (o end))
487 | (let end (if (no end) (len seq)
488 | (< end 0) (+ (len seq) end)
489 | end)
490 | (if (isa seq 'string)
491 | (let s2 (newstring (- end start))
492 | (for i 0 (- end start 1)
493 | (= (s2 i) (seq (+ start i))))
494 | s2)
495 | (firstn (- end start) (nthcdr start seq)))))
496 |
497 | (mac whilet (var test . body)
498 | (w/uniq (gf gp)
499 | `((rfn ,gf (,gp)
500 | (let ,var ,gp
501 | (when ,var ,@body (,gf ,test))))
502 | ,test)))
503 |
504 | (def last (xs)
505 | (if (cdr xs)
506 | (last (cdr xs))
507 | (car xs)))
508 |
509 | (def rem (test seq)
510 | (let f (testify test)
511 | (if (alist seq)
512 | ((afn (s)
513 | (if (no s) nil
514 | (f (car s)) (self (cdr s))
515 | (cons (car s) (self (cdr s)))))
516 | seq)
517 | (coerce (rem test (coerce seq 'cons)) 'string))))
518 |
519 | ; Seems like keep doesn't need to testify-- would be better to
520 | ; be able to use tables as fns. But rem does need to, because
521 | ; often want to rem a table from a list. So maybe the right answer
522 | ; is to make keep the more primitive, not rem.
523 |
524 | (def keep (test seq)
525 | (rem (complement (testify test)) seq))
526 |
527 | ;(def trues (f seq)
528 | ; (rem nil (map f seq)))
529 |
530 | (def trues (f xs)
531 | (and xs
532 | (let fx (f (car xs))
533 | (if fx
534 | (cons fx (trues f (cdr xs)))
535 | (trues f (cdr xs))))))
536 |
537 | (mac do1 args
538 | (w/uniq g
539 | `(let ,g ,(car args)
540 | ,@(cdr args)
541 | ,g)))
542 |
543 | ; Would like to write a faster case based on table generated by a macro,
544 | ; but can't insert objects into expansions in Mzscheme.
545 |
546 | (mac caselet (var expr . args)
547 | (let ex (afn (args)
548 | (if (no (cdr args))
549 | (car args)
550 | `(if (is ,var ',(car args))
551 | ,(cadr args)
552 | ,(self (cddr args)))))
553 | `(let ,var ,expr ,(ex args))))
554 |
555 | (mac case (expr . args)
556 | `(caselet ,(uniq) ,expr ,@args))
557 |
558 | (mac push (x place)
559 | (w/uniq gx
560 | (let (binds val setter) (setforms place)
561 | `(let ,gx ,x
562 | (atwiths ,binds
563 | (,setter (cons ,gx ,val)))))))
564 |
565 | (mac swap (place1 place2)
566 | (w/uniq (g1 g2)
567 | (with ((binds1 val1 setter1) (setforms place1)
568 | (binds2 val2 setter2) (setforms place2))
569 | `(atwiths ,(+ binds1 (list g1 val1) binds2 (list g2 val2))
570 | (,setter1 ,g2)
571 | (,setter2 ,g1)))))
572 |
573 | (mac rotate places
574 | (with (vars (map [uniq] places)
575 | forms (map setforms places))
576 | `(atwiths ,(mappend (fn (g (binds val setter))
577 | (+ binds (list g val)))
578 | vars
579 | forms)
580 | ,@(map (fn (g (binds val setter))
581 | (list setter g))
582 | (+ (cdr vars) (list (car vars)))
583 | forms))))
584 |
585 | (mac pop (place)
586 | (w/uniq g
587 | (let (binds val setter) (setforms place)
588 | `(atwiths ,(+ binds (list g val))
589 | (do1 (car ,g)
590 | (,setter (cdr ,g)))))))
591 |
592 | (def adjoin (x xs (o test iso))
593 | (if (some [test x _] xs)
594 | xs
595 | (cons x xs)))
596 |
597 | (mac pushnew (x place . args)
598 | (w/uniq gx
599 | (let (binds val setter) (setforms place)
600 | `(atwiths ,(+ (list gx x) binds)
601 | (,setter (adjoin ,gx ,val ,@args))))))
602 |
603 | (mac pull (test place)
604 | (w/uniq g
605 | (let (binds val setter) (setforms place)
606 | `(atwiths ,(+ (list g test) binds)
607 | (,setter (rem ,g ,val))))))
608 |
609 | (mac togglemem (x place . args)
610 | (w/uniq gx
611 | (let (binds val setter) (setforms place)
612 | `(atwiths ,(+ (list gx x) binds)
613 | (,setter (if (mem ,gx ,val)
614 | (rem ,gx ,val)
615 | (adjoin ,gx ,val ,@args)))))))
616 |
617 | (mac ++ (place (o i 1))
618 | (if (isa place 'sym)
619 | `(= ,place (+ ,place ,i))
620 | (w/uniq gi
621 | (let (binds val setter) (setforms place)
622 | `(atwiths ,(+ binds (list gi i))
623 | (,setter (+ ,val ,gi)))))))
624 |
625 | (mac -- (place (o i 1))
626 | (if (isa place 'sym)
627 | `(= ,place (- ,place ,i))
628 | (w/uniq gi
629 | (let (binds val setter) (setforms place)
630 | `(atwiths ,(+ binds (list gi i))
631 | (,setter (- ,val ,gi)))))))
632 |
633 | ; E.g. (++ x) equiv to (zap + x 1)
634 |
635 | (mac zap (op place . args)
636 | (with (gop (uniq)
637 | gargs (map [uniq] args)
638 | mix (afn seqs
639 | (if (some no seqs)
640 | nil
641 | (+ (map car seqs)
642 | (apply self (map cdr seqs))))))
643 | (let (binds val setter) (setforms place)
644 | `(atwiths ,(+ binds (list gop op) (mix gargs args))
645 | (,setter (,gop ,val ,@gargs))))))
646 |
647 | ; Can't simply mod pr to print strings represented as lists of chars,
648 | ; because empty string will get printed as nil. Would need to rep strings
649 | ; as lists of chars annotated with 'string, and modify car and cdr to get
650 | ; the rep of these. That would also require hacking the reader.
651 |
652 | (def pr args
653 | (map1 disp args)
654 | (car args))
655 |
656 | (def prt args
657 | (map1 [if _ (disp _)] args)
658 | (car args))
659 |
660 | (def prn args
661 | (do1 (apply pr args)
662 | (writec #\newline)))
663 |
664 | (mac wipe args
665 | `(do ,@(map (fn (a) `(= ,a nil)) args)))
666 |
667 | (mac set args
668 | `(do ,@(map (fn (a) `(= ,a t)) args)))
669 |
670 | ; Destructuring means ambiguity: are pat vars bound in else? (no)
671 |
672 | (mac iflet (var expr then . rest)
673 | (w/uniq gv
674 | `(let ,gv ,expr
675 | (if ,gv (let ,var ,gv ,then) ,@rest))))
676 |
677 | (mac whenlet (var expr . body)
678 | `(iflet ,var ,expr (do ,@body)))
679 |
680 | (mac aif (expr . body)
681 | `(let it ,expr
682 | (if it
683 | ,@(if (cddr body)
684 | `(,(car body) (aif ,@(cdr body)))
685 | body))))
686 |
687 | (mac awhen (expr . body)
688 | `(let it ,expr (if it (do ,@body))))
689 |
690 | (mac aand args
691 | (if (no args)
692 | 't
693 | (no (cdr args))
694 | (car args)
695 | `(let it ,(car args) (and it (aand ,@(cdr args))))))
696 |
697 | (mac accum (accfn . body)
698 | (w/uniq gacc
699 | `(withs (,gacc nil ,accfn [push _ ,gacc])
700 | ,@body
701 | (rev ,gacc))))
702 |
703 | ; Repeatedly evaluates its body till it returns nil, then returns vals.
704 |
705 | (mac drain (expr (o eof nil))
706 | (w/uniq (gacc gdone gres)
707 | `(with (,gacc nil ,gdone nil)
708 | (while (no ,gdone)
709 | (let ,gres ,expr
710 | (if (is ,gres ,eof)
711 | (= ,gdone t)
712 | (push ,gres ,gacc))))
713 | (rev ,gacc))))
714 |
715 | ; For the common C idiom while x = snarfdata != stopval.
716 | ; Rename this if use it often.
717 |
718 | (mac whiler (var expr endval . body)
719 | (w/uniq gf
720 | `(withs (,var nil ,gf (testify ,endval))
721 | (while (no (,gf (= ,var ,expr)))
722 | ,@body))))
723 |
724 | ;(def macex (e)
725 | ; (if (atom e)
726 | ; e
727 | ; (let op (and (atom (car e)) (eval (car e)))
728 | ; (if (isa op 'mac)
729 | ; (apply (rep op) (cdr e))
730 | ; e))))
731 |
732 | (def consif (x y) (if x (cons x y) y))
733 |
734 | (def string args
735 | (apply + "" (map [coerce _ 'string] args)))
736 |
737 | (def flat x
738 | ((afn (x acc)
739 | (if (no x) acc
740 | (atom x) (cons x acc)
741 | (self (car x) (self (cdr x) acc))))
742 | x nil))
743 |
744 | (mac check (x test (o alt))
745 | (w/uniq gx
746 | `(let ,gx ,x
747 | (if (,test ,gx) ,gx ,alt))))
748 |
749 | (def pos (test seq (o start 0))
750 | (let f (testify test)
751 | (if (alist seq)
752 | ((afn (seq n)
753 | (if (no seq)
754 | nil
755 | (f (car seq))
756 | n
757 | (self (cdr seq) (+ n 1))))
758 | (nthcdr start seq)
759 | start)
760 | (recstring [if (f (seq _)) _] seq start))))
761 |
762 | (def even (n) (is (mod n 2) 0))
763 |
764 | (def odd (n) (no (even n)))
765 |
766 | (mac after (x . ys)
767 | `(protect (fn () ,x) (fn () ,@ys)))
768 |
769 | (let expander
770 | (fn (f var name body)
771 | `(let ,var (,f ,name)
772 | (after (do ,@body) (close ,var))))
773 |
774 | (mac w/infile (var name . body)
775 | (expander 'infile var name body))
776 |
777 | (mac w/outfile (var name . body)
778 | (expander 'outfile var name body))
779 |
780 | (mac w/instring (var str . body)
781 | (expander 'instring var str body))
782 |
783 | (mac w/socket (var port . body)
784 | (expander 'open-socket var port body))
785 | )
786 |
787 | (mac w/outstring (var . body)
788 | `(let ,var (outstring) ,@body))
789 |
790 | ; what happens to a file opened for append if arc is killed in
791 | ; the middle of a write?
792 |
793 | (mac w/appendfile (var name . body)
794 | `(let ,var (outfile ,name 'append)
795 | (after (do ,@body) (close ,var))))
796 |
797 | ; rename this simply "to"? - prob not; rarely use
798 |
799 | (mac w/stdout (str . body)
800 | `(call-w/stdout ,str (fn () ,@body)))
801 |
802 | (mac w/stdin (str . body)
803 | `(call-w/stdin ,str (fn () ,@body)))
804 |
805 | (mac tostring body
806 | (w/uniq gv
807 | `(w/outstring ,gv
808 | (w/stdout ,gv ,@body)
809 | (inside ,gv))))
810 |
811 | (mac fromstring (str . body)
812 | (w/uniq gv
813 | `(w/instring ,gv ,str
814 | (w/stdin ,gv ,@body))))
815 |
816 | (def readstring1 (s (o eof nil)) (w/instring i s (read i eof)))
817 |
818 | (def read ((o x (stdin)) (o eof nil))
819 | (if (isa x 'string) (readstring1 x eof) (sread x eof)))
820 |
821 | ; inconsistency between names of readfile[1] and writefile
822 |
823 | (def readfile (name) (w/infile s name (drain (read s))))
824 |
825 | (def readfile1 (name) (w/infile s name (read s)))
826 |
827 | (def readall (src (o eof nil))
828 | ((afn (i)
829 | (let x (read i eof)
830 | (if (is x eof)
831 | nil
832 | (cons x (self i)))))
833 | (if (isa src 'string) (instring src) src)))
834 |
835 | (def allchars (str)
836 | (tostring (whiler c (readc str nil) no
837 | (writec c))))
838 |
839 | (def filechars (name)
840 | (w/infile s name (allchars s)))
841 |
842 | (def writefile (val file)
843 | (let tmpfile (+ file ".tmp")
844 | (w/outfile o tmpfile (write val o))
845 | (mvfile tmpfile file))
846 | val)
847 |
848 | (def sym (x) (coerce x 'sym))
849 |
850 | (def int (x (o b 10)) (coerce x 'int b))
851 |
852 | (mac rand-choice exprs
853 | `(case (rand ,(len exprs))
854 | ,@(let key -1
855 | (mappend [list (++ key) _]
856 | exprs))))
857 |
858 | (mac n-of (n expr)
859 | (w/uniq ga
860 | `(let ,ga nil
861 | (repeat ,n (push ,expr ,ga))
862 | (rev ,ga))))
863 |
864 | ; rejects bytes >= 248 lest digits be overrepresented
865 |
866 | (def rand-string (n)
867 | (let c "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
868 | (with (nc 62 s (newstring n) i 0)
869 | (w/infile str "/dev/urandom"
870 | (while (< i n)
871 | (let x (readb str)
872 | (unless (> x 247)
873 | (= (s i) (c (mod x nc)))
874 | (++ i)))))
875 | s)))
876 |
877 | (mac forlen (var s . body)
878 | `(for ,var 0 (- (len ,s) 1) ,@body))
879 |
880 | (mac on (var s . body)
881 | (if (is var 'index)
882 | (err "Can't use index as first arg to on.")
883 | (w/uniq gs
884 | `(let ,gs ,s
885 | (forlen index ,gs
886 | (let ,var (,gs index)
887 | ,@body))))))
888 |
889 | (def best (f seq)
890 | (if (no seq)
891 | nil
892 | (let wins (car seq)
893 | (each elt (cdr seq)
894 | (if (f elt wins) (= wins elt)))
895 | wins)))
896 |
897 | (def max args (best > args))
898 | (def min args (best < args))
899 |
900 | ; (mac max2 (x y)
901 | ; (w/uniq (a b)
902 | ; `(with (,a ,x ,b ,y) (if (> ,a ,b) ,a ,b))))
903 |
904 | (def most (f seq)
905 | (unless (no seq)
906 | (withs (wins (car seq) topscore (f wins))
907 | (each elt (cdr seq)
908 | (let score (f elt)
909 | (if (> score topscore) (= wins elt topscore score))))
910 | wins)))
911 |
912 | ; Insert so that list remains sorted. Don't really want to expose
913 | ; these but seem to have to because can't include a fn obj in a
914 | ; macroexpansion.
915 |
916 | (def insert-sorted (test elt seq)
917 | (if (no seq)
918 | (list elt)
919 | (test elt (car seq))
920 | (cons elt seq)
921 | (cons (car seq) (insert-sorted test elt (cdr seq)))))
922 |
923 | (mac insort (test elt seq)
924 | `(zap [insert-sorted ,test ,elt _] ,seq))
925 |
926 | (def reinsert-sorted (test elt seq)
927 | (if (no seq)
928 | (list elt)
929 | (is elt (car seq))
930 | (reinsert-sorted test elt (cdr seq))
931 | (test elt (car seq))
932 | (cons elt (rem elt seq))
933 | (cons (car seq) (reinsert-sorted test elt (cdr seq)))))
934 |
935 | (mac insortnew (test elt seq)
936 | `(zap [reinsert-sorted ,test ,elt _] ,seq))
937 |
938 | ; Could make this look at the sig of f and return a fn that took the
939 | ; right no of args and didn't have to call apply (or list if 1 arg).
940 |
941 | (def memo (f)
942 | (with (cache (table) nilcache (table))
943 | (fn args
944 | (or (cache args)
945 | (and (no (nilcache args))
946 | (aif (apply f args)
947 | (= (cache args) it)
948 | (do (set (nilcache args))
949 | nil)))))))
950 |
951 |
952 | (mac defmemo (name parms . body)
953 | `(safeset ,name (memo (fn ,parms ,@body))))
954 |
955 | (def <= args
956 | (or (no args)
957 | (no (cdr args))
958 | (and (no (> (car args) (cadr args)))
959 | (apply <= (cdr args)))))
960 |
961 | (def >= args
962 | (or (no args)
963 | (no (cdr args))
964 | (and (no (< (car args) (cadr args)))
965 | (apply >= (cdr args)))))
966 |
967 | (def whitec (c)
968 | (in c #\space #\newline #\tab #\return))
969 |
970 | (def nonwhite (c) (no (whitec c)))
971 |
972 | (def letter (c) (or (<= #\a c #\z) (<= #\A c #\Z)))
973 |
974 | (def digit (c) (<= #\0 c #\9))
975 |
976 | (def alphadig (c) (or (letter c) (digit c)))
977 |
978 | (def punc (c)
979 | (in c #\. #\, #\; #\: #\! #\?))
980 |
981 | (def readline ((o str (stdin)))
982 | (awhen (readc str)
983 | (tostring
984 | (writec it)
985 | (whiler c (readc str) [in _ nil #\newline]
986 | (writec c)))))
987 |
988 | ; Don't currently use this but suspect some code could.
989 |
990 | (mac summing (sumfn . body)
991 | (w/uniq (gc gt)
992 | `(let ,gc 0
993 | (let ,sumfn (fn (,gt) (if ,gt (++ ,gc)))
994 | ,@body)
995 | ,gc)))
996 |
997 | (def sum (f xs)
998 | (let n 0
999 | (each x xs (++ n (f x)))
1000 | n))
1001 |
1002 | (def treewise (f base tree)
1003 | (if (atom tree)
1004 | (base tree)
1005 | (f (treewise f base (car tree))
1006 | (treewise f base (cdr tree)))))
1007 |
1008 | (def carif (x) (if (atom x) x (car x)))
1009 |
1010 | ; Could prob be generalized beyond printing.
1011 |
1012 | (def prall (elts (o init "") (o sep ", "))
1013 | (when elts
1014 | (pr init (car elts))
1015 | (map [pr sep _] (cdr elts))
1016 | elts))
1017 |
1018 | (def prs args
1019 | (prall args "" #\space))
1020 |
1021 | (def tree-subst (old new tree)
1022 | (if (is tree old)
1023 | new
1024 | (atom tree)
1025 | tree
1026 | (cons (tree-subst old new (car tree))
1027 | (tree-subst old new (cdr tree)))))
1028 |
1029 | (def ontree (f tree)
1030 | (f tree)
1031 | (unless (atom tree)
1032 | (ontree f (car tree))
1033 | (ontree f (cdr tree))))
1034 |
1035 | (def dotted (x)
1036 | (if (atom x)
1037 | nil
1038 | (and (cdr x) (or (atom (cdr x))
1039 | (dotted (cdr x))))))
1040 |
1041 | (def fill-table (table data)
1042 | (each (k v) (pair data) (= (table k) v))
1043 | table)
1044 |
1045 | (def keys (h)
1046 | (accum a (each (k v) h (a k))))
1047 |
1048 | (def vals (h)
1049 | (accum a (each (k v) h (a v))))
1050 |
1051 | ; These two should really be done by coerce. Wrap coerce?
1052 |
1053 | (def tablist (h)
1054 | (accum a (maptable (fn args (a args)) h)))
1055 |
1056 | (def listtab (al)
1057 | (let h (table)
1058 | (map (fn ((k v)) (= (h k) v))
1059 | al)
1060 | h))
1061 |
1062 | (mac obj args
1063 | `(listtab (list ,@(map (fn ((k v))
1064 | `(list ',k ,v))
1065 | (pair args)))))
1066 |
1067 | (def load-table (file (o eof))
1068 | (w/infile i file (read-table i eof)))
1069 |
1070 | (def read-table ((o i (stdin)) (o eof))
1071 | (let e (read i eof)
1072 | (if (alist e) (listtab e) e)))
1073 |
1074 | (def load-tables (file)
1075 | (w/infile i file
1076 | (w/uniq eof
1077 | (drain (read-table i eof) eof))))
1078 |
1079 | (def save-table (h file)
1080 | (writefile (tablist h) file))
1081 |
1082 | (def write-table (h (o o (stdout)))
1083 | (write (tablist h) o))
1084 |
1085 | (def copy (x . args)
1086 | (let x2 (case (type x)
1087 | sym x
1088 | cons (copylist x) ; (apply (fn args args) x)
1089 | string (let new (newstring (len x))
1090 | (forlen i x
1091 | (= (new i) (x i)))
1092 | new)
1093 | table (let new (table)
1094 | (each (k v) x
1095 | (= (new k) v))
1096 | new)
1097 | (err "Can't copy " x))
1098 | (map (fn ((k v)) (= (x2 k) v))
1099 | (pair args))
1100 | x2))
1101 |
1102 | (def abs (n)
1103 | (if (< n 0) (- n) n))
1104 |
1105 | ; The problem with returning a list instead of multiple values is that
1106 | ; you can't act as if the fn didn't return multiple vals in cases where
1107 | ; you only want the first. Not a big problem.
1108 |
1109 | (def round (n)
1110 | (withs (base (trunc n) rem (abs (- n base)))
1111 | (if (> rem 1/2) ((if (> n 0) + -) base 1)
1112 | (< rem 1/2) base
1113 | (odd base) ((if (> n 0) + -) base 1)
1114 | base)))
1115 |
1116 | (def roundup (n)
1117 | (withs (base (trunc n) rem (abs (- n base)))
1118 | (if (>= rem 1/2)
1119 | ((if (> n 0) + -) base 1)
1120 | base)))
1121 |
1122 | (def nearest (n quantum)
1123 | (* (roundup (/ n quantum)) quantum))
1124 |
1125 | (def avg (ns) (/ (apply + ns) (len ns)))
1126 |
1127 | (def med (ns (o test >))
1128 | ((sort test ns) (round (/ (len ns) 2))))
1129 |
1130 | ; Use mergesort on assumption that mostly sorting mostly sorted lists
1131 | ; benchmark: (let td (n-of 10000 (rand 100)) (time (sort < td)) 1)
1132 |
1133 | (def sort (test seq)
1134 | (if (alist seq)
1135 | (mergesort test (copy seq))
1136 | (coerce (mergesort test (coerce seq 'cons)) (type seq))))
1137 |
1138 | ; Destructive stable merge-sort, adapted from slib and improved
1139 | ; by Eli Barzilay for MzLib; re-written in Arc.
1140 |
1141 | (def mergesort (less? lst)
1142 | (with (n (len lst))
1143 | (if (<= n 1) lst
1144 | ; ; check if the list is already sorted
1145 | ; ; (which can be a common case, eg, directory lists).
1146 | ; (let loop ([last (car lst)] [next (cdr lst)])
1147 | ; (or (null? next)
1148 | ; (and (not (less? (car next) last))
1149 | ; (loop (car next) (cdr next)))))
1150 | ; lst
1151 | ((afn (n)
1152 | (if (> n 2)
1153 | ; needs to evaluate L->R
1154 | (withs (j (/ (if (even n) n (- n 1)) 2) ; faster than round
1155 | a (self j)
1156 | b (self (- n j)))
1157 | (merge less? a b))
1158 | ; the following case just inlines the length 2 case,
1159 | ; it can be removed (and use the above case for n>1)
1160 | ; and the code still works, except a little slower
1161 | (is n 2)
1162 | (with (x (car lst) y (cadr lst) p lst)
1163 | (= lst (cddr lst))
1164 | (when (less? y x) (scar p y) (scar (cdr p) x))
1165 | (scdr (cdr p) nil)
1166 | p)
1167 | (is n 1)
1168 | (with (p lst)
1169 | (= lst (cdr lst))
1170 | (scdr p nil)
1171 | p)
1172 | nil))
1173 | n))))
1174 |
1175 | ; Also by Eli.
1176 |
1177 | (def merge (less? x y)
1178 | (if (no x) y
1179 | (no y) x
1180 | (let lup nil
1181 | (assign lup
1182 | (fn (r x y r-x?) ; r-x? for optimization -- is r connected to x?
1183 | (if (less? (car y) (car x))
1184 | (do (if r-x? (scdr r y))
1185 | (if (cdr y) (lup y x (cdr y) nil) (scdr y x)))
1186 | ; (car x) <= (car y)
1187 | (do (if (no r-x?) (scdr r x))
1188 | (if (cdr x) (lup x (cdr x) y t) (scdr x y))))))
1189 | (if (less? (car y) (car x))
1190 | (do (if (cdr y) (lup y x (cdr y) nil) (scdr y x))
1191 | y)
1192 | ; (car x) <= (car y)
1193 | (do (if (cdr x) (lup x (cdr x) y t) (scdr x y))
1194 | x)))))
1195 |
1196 | (def bestn (n f seq)
1197 | (firstn n (sort f seq)))
1198 |
1199 | (def split (seq pos)
1200 | (list (cut seq 0 pos) (cut seq pos)))
1201 |
1202 | (mac time (expr)
1203 | (w/uniq (t1 t2)
1204 | `(let ,t1 (msec)
1205 | (do1 ,expr
1206 | (let ,t2 (msec)
1207 | (prn "time: " (- ,t2 ,t1) " msec."))))))
1208 |
1209 | (mac jtime (expr)
1210 | `(do1 'ok (time ,expr)))
1211 |
1212 | (mac time10 (expr)
1213 | `(time (repeat 10 ,expr)))
1214 |
1215 | (def union (f xs ys)
1216 | (+ xs (rem (fn (y) (some [f _ y] xs))
1217 | ys)))
1218 |
1219 | (= templates* (table))
1220 |
1221 | (mac deftem (tem . fields)
1222 | (withs (name (carif tem) includes (if (acons tem) (cdr tem)))
1223 | `(= (templates* ',name)
1224 | (+ (mappend templates* ',(rev includes))
1225 | (list ,@(map (fn ((k v)) `(list ',k (fn () ,v)))
1226 | (pair fields)))))))
1227 |
1228 | (mac addtem (name . fields)
1229 | `(= (templates* ',name)
1230 | (union (fn (x y) (is (car x) (car y)))
1231 | (list ,@(map (fn ((k v)) `(list ',k (fn () ,v)))
1232 | (pair fields)))
1233 | (templates* ',name))))
1234 |
1235 | (def inst (tem . args)
1236 | (let x (table)
1237 | (each (k v) (if (acons tem) tem (templates* tem))
1238 | (unless (no v) (= (x k) (v))))
1239 | (each (k v) (pair args)
1240 | (= (x k) v))
1241 | x))
1242 |
1243 | ; To write something to be read by temread, (write (tablist x))
1244 |
1245 | (def temread (tem (o str (stdin)))
1246 | (templatize tem (read str)))
1247 |
1248 | ; Converts alist to inst; ugly; maybe should make this part of coerce.
1249 | ; Note: discards fields not defined by the template.
1250 |
1251 | (def templatize (tem raw)
1252 | (with (x (inst tem) fields (if (acons tem) tem (templates* tem)))
1253 | (each (k v) raw
1254 | (when (assoc k fields)
1255 | (= (x k) v)))
1256 | x))
1257 |
1258 | (def temload (tem file)
1259 | (w/infile i file (temread tem i)))
1260 |
1261 | (def temloadall (tem file)
1262 | (map (fn (pairs) (templatize tem pairs))
1263 | (w/infile in file (readall in))))
1264 |
1265 |
1266 | (def number (n) (in (type n) 'int 'num))
1267 |
1268 | (def since (t1) (- (seconds) t1))
1269 |
1270 | (def minutes-since (t1) (/ (since t1) 60))
1271 | (def hours-since (t1) (/ (since t1) 3600))
1272 | (def days-since (t1) (/ (since t1) 86400))
1273 |
1274 | ; could use a version for fns of 1 arg at least
1275 |
1276 | (def cache (timef valf)
1277 | (with (cached nil gentime nil)
1278 | (fn ()
1279 | (unless (and cached (< (since gentime) (timef)))
1280 | (= cached (valf)
1281 | gentime (seconds)))
1282 | cached)))
1283 |
1284 | (mac defcache (name lasts . body)
1285 | `(safeset ,name (cache (fn () ,lasts)
1286 | (fn () ,@body))))
1287 |
1288 | (mac errsafe (expr)
1289 | `(on-err (fn (c) nil)
1290 | (fn () ,expr)))
1291 |
1292 | (def saferead (arg) (errsafe:read arg))
1293 |
1294 | (def safe-load-table (filename)
1295 | (or (errsafe:load-table filename)
1296 | (table)))
1297 |
1298 | (def ensure-dir (path)
1299 | (unless (dir-exists path)
1300 | (system (string "mkdir -p " path))))
1301 |
1302 | (def date ((o s (seconds)))
1303 | (rev (nthcdr 3 (timedate s))))
1304 |
1305 | (def datestring ((o s (seconds)))
1306 | (let (y m d) (date s)
1307 | (string y "-" (if (< m 10) "0") m "-" (if (< d 10) "0") d)))
1308 |
1309 | (def count (test x)
1310 | (with (n 0 testf (testify test))
1311 | (each elt x
1312 | (if (testf elt) (++ n)))
1313 | n))
1314 |
1315 | (def ellipsize (str (o limit 80))
1316 | (if (<= (len str) limit)
1317 | str
1318 | (+ (cut str 0 limit) "...")))
1319 |
1320 | (def rand-elt (seq)
1321 | (seq (rand (len seq))))
1322 |
1323 | (mac until (test . body)
1324 | `(while (no ,test) ,@body))
1325 |
1326 | (def before (x y seq (o i 0))
1327 | (with (xp (pos x seq i) yp (pos y seq i))
1328 | (and xp (or (no yp) (< xp yp)))))
1329 |
1330 | (def orf fns
1331 | (fn args
1332 | ((afn (fs)
1333 | (and fs (or (apply (car fs) args) (self (cdr fs)))))
1334 | fns)))
1335 |
1336 | (def andf fns
1337 | (fn args
1338 | ((afn (fs)
1339 | (if (no fs) t
1340 | (no (cdr fs)) (apply (car fs) args)
1341 | (and (apply (car fs) args) (self (cdr fs)))))
1342 | fns)))
1343 |
1344 | (def atend (i s)
1345 | (> i (- (len s) 2)))
1346 |
1347 | (def multiple (x y)
1348 | (is 0 (mod x y)))
1349 |
1350 | (mac nor args `(no (or ,@args)))
1351 |
1352 | ; Consider making the default sort fn take compare's two args (when do
1353 | ; you ever have to sort mere lists of numbers?) and rename current sort
1354 | ; as prim-sort or something.
1355 |
1356 | ; Could simply modify e.g. > so that (> len) returned the same thing
1357 | ; as (compare > len).
1358 |
1359 | (def compare (comparer scorer)
1360 | (fn (x y) (comparer (scorer x) (scorer y))))
1361 |
1362 | ; Cleaner thus, but may only ever need in 2 arg case.
1363 |
1364 | ;(def compare (comparer scorer)
1365 | ; (fn args (apply comparer map scorer args)))
1366 |
1367 | ; (def only (f g . args) (aif (apply g args) (f it)))
1368 |
1369 | (def only (f)
1370 | (fn args (if (car args) (apply f args))))
1371 |
1372 | (mac conswhen (f x y)
1373 | (w/uniq (gf gx)
1374 | `(with (,gf ,f ,gx ,x)
1375 | (if (,gf ,gx) (cons ,gx ,y) ,y))))
1376 |
1377 | ; Could combine with firstn if put f arg last, default to (fn (x) t).
1378 |
1379 | (def retrieve (n f xs)
1380 | (if (no n) (keep f xs)
1381 | (or (<= n 0) (no xs)) nil
1382 | (f (car xs)) (cons (car xs) (retrieve (- n 1) f (cdr xs)))
1383 | (retrieve n f (cdr xs))))
1384 |
1385 | (def dedup (xs)
1386 | (with (h (table) acc nil)
1387 | (each x xs
1388 | (unless (h x)
1389 | (push x acc)
1390 | (set (h x))))
1391 | (rev acc)))
1392 |
1393 | (def single (x) (and (acons x) (no (cdr x))))
1394 |
1395 | (def intersperse (x ys)
1396 | (and ys (cons (car ys)
1397 | (mappend [list x _] (cdr ys)))))
1398 |
1399 | (def counts (seq (o c (table)))
1400 | (if (no seq)
1401 | c
1402 | (do (++ (c (car seq) 0))
1403 | (counts (cdr seq) c))))
1404 |
1405 | (def commonest (seq)
1406 | (with (winner nil n 0)
1407 | (each (k v) (counts seq)
1408 | (when (> v n) (= winner k n v)))
1409 | (list winner n)))
1410 |
1411 | (def reduce (f xs)
1412 | (if (cddr xs)
1413 | (reduce f (cons (f (car xs) (cadr xs)) (cddr xs)))
1414 | (apply f xs)))
1415 |
1416 | (def rreduce (f xs)
1417 | (if (cddr xs)
1418 | (f (car xs) (rreduce f (cdr xs)))
1419 | (apply f xs)))
1420 |
1421 | (let argsym (uniq)
1422 |
1423 | (def parse-format (str)
1424 | (accum a
1425 | (with (chars nil i -1)
1426 | (w/instring s str
1427 | (whilet c (readc s)
1428 | (case c
1429 | #\# (do (a (coerce (rev chars) 'string))
1430 | (wipe chars)
1431 | (a (read s)))
1432 | #\~ (do (a (coerce (rev chars) 'string))
1433 | (wipe chars)
1434 | (readc s)
1435 | (a (list argsym (++ i))))
1436 | (push c chars))))
1437 | (when chars
1438 | (a (coerce (rev chars) 'string))))))
1439 |
1440 | (mac prf (str . args)
1441 | `(let ,argsym (list ,@args)
1442 | (pr ,@(parse-format str))))
1443 | )
1444 |
1445 | (def load (file)
1446 | (w/infile f file
1447 | (w/uniq eof
1448 | (whiler e (read f eof) eof
1449 | (eval e)))))
1450 |
1451 | (def positive (x)
1452 | (and (number x) (> x 0)))
1453 |
1454 | (mac w/table (var . body)
1455 | `(let ,var (table) ,@body ,var))
1456 |
1457 | (def ero args
1458 | (w/stdout (stderr)
1459 | (each a args
1460 | (write a)
1461 | (writec #\space))
1462 | (writec #\newline))
1463 | (car args))
1464 |
1465 | (def queue () (list nil nil 0))
1466 |
1467 | ; Despite call to atomic, once had some sign this wasn't thread-safe.
1468 | ; Keep an eye on it.
1469 |
1470 | (def enq (obj q)
1471 | (atomic
1472 | (++ (q 2))
1473 | (if (no (car q))
1474 | (= (cadr q) (= (car q) (list obj)))
1475 | (= (cdr (cadr q)) (list obj)
1476 | (cadr q) (cdr (cadr q))))
1477 | (car q)))
1478 |
1479 | (def deq (q)
1480 | (atomic (unless (is (q 2) 0) (-- (q 2)))
1481 | (pop (car q))))
1482 |
1483 | ; Should redef len to do this, and make queues lists annotated queue.
1484 |
1485 | (def qlen (q) (q 2))
1486 |
1487 | (def qlist (q) (car q))
1488 |
1489 | (def enq-limit (val q (o limit 1000))
1490 | (atomic
1491 | (unless (< (qlen q) limit)
1492 | (deq q))
1493 | (enq val q)))
1494 |
1495 | (def median (ns)
1496 | ((sort > ns) (trunc (/ (len ns) 2))))
1497 |
1498 | (mac noisy-each (n var val . body)
1499 | (w/uniq (gn gc)
1500 | `(with (,gn ,n ,gc 0)
1501 | (each ,var ,val
1502 | (when (multiple (++ ,gc) ,gn)
1503 | (pr ".")
1504 | (flushout)
1505 | )
1506 | ,@body)
1507 | (prn)
1508 | (flushout))))
1509 |
1510 | (mac point (name . body)
1511 | (w/uniq (g p)
1512 | `(ccc (fn (,g)
1513 | (let ,name (fn ((o ,p)) (,g ,p))
1514 | ,@body)))))
1515 |
1516 | (mac catch body
1517 | `(point throw ,@body))
1518 |
1519 | (def downcase (x)
1520 | (let downc (fn (c)
1521 | (let n (coerce c 'int)
1522 | (if (or (< 64 n 91) (< 191 n 215) (< 215 n 223))
1523 | (coerce (+ n 32) 'char)
1524 | c)))
1525 | (case (type x)
1526 | string (map downc x)
1527 | char (downc x)
1528 | sym (sym (map downc (coerce x 'string)))
1529 | (err "Can't downcase" x))))
1530 |
1531 | (def upcase (x)
1532 | (let upc (fn (c)
1533 | (let n (coerce c 'int)
1534 | (if (or (< 96 n 123) (< 223 n 247) (< 247 n 255))
1535 | (coerce (- n 32) 'char)
1536 | c)))
1537 | (case (type x)
1538 | string (map upc x)
1539 | char (upc x)
1540 | sym (sym (map upc (coerce x 'string)))
1541 | (err "Can't upcase" x))))
1542 |
1543 | (def inc (x (o n 1))
1544 | (coerce (+ (coerce x 'int) n) (type x)))
1545 |
1546 | (def range (start end)
1547 | (if (> start end)
1548 | nil
1549 | (cons start (range (inc start) end))))
1550 |
1551 | (def mismatch (s1 s2)
1552 | (catch
1553 | (on c s1
1554 | (when (isnt c (s2 index))
1555 | (throw index)))))
1556 |
1557 | (def memtable (ks)
1558 | (let h (table)
1559 | (each k ks (set (h k)))
1560 | h))
1561 |
1562 | (= bar* " | ")
1563 |
1564 | (mac w/bars body
1565 | (w/uniq (out needbars)
1566 | `(let ,needbars nil
1567 | (do ,@(map (fn (e)
1568 | `(let ,out (tostring ,e)
1569 | (unless (is ,out "")
1570 | (if ,needbars
1571 | (pr bar* ,out)
1572 | (do (set ,needbars)
1573 | (pr ,out))))))
1574 | body)))))
1575 |
1576 | (def len< (x n) (< (len x) n))
1577 |
1578 | (def len> (x n) (> (len x) n))
1579 |
1580 | (mac thread body
1581 | `(new-thread (fn () ,@body)))
1582 |
1583 | (mac trav (x . fs)
1584 | (w/uniq g
1585 | `((afn (,g)
1586 | (when ,g
1587 | ,@(map [list _ g] fs)))
1588 | ,x)))
1589 |
1590 | (mac or= (place expr)
1591 | (let (binds val setter) (setforms place)
1592 | `(atwiths ,binds
1593 | (or ,val (,setter ,expr)))))
1594 |
1595 | (= hooks* (table))
1596 |
1597 | (def hook (name . args)
1598 | (aif (hooks* name) (apply it args)))
1599 |
1600 | (mac defhook (name . rest)
1601 | `(= (hooks* ',name) (fn ,@rest)))
1602 |
1603 | (mac out (expr) `(pr ,(tostring (eval expr))))
1604 |
1605 | ; if renamed this would be more natural for (map [_ user] pagefns*)
1606 |
1607 | (def get (index) [_ index])
1608 |
1609 | (= savers* (table))
1610 |
1611 | (mac fromdisk (var file init load save)
1612 | (w/uniq (gf gv)
1613 | `(unless (bound ',var)
1614 | (do1 (= ,var (iflet ,gf (file-exists ,file)
1615 | (,load ,gf)
1616 | ,init))
1617 | (= (savers* ',var) (fn (,gv) (,save ,gv ,file)))))))
1618 |
1619 | (mac diskvar (var file)
1620 | `(fromdisk ,var ,file nil readfile1 writefile))
1621 |
1622 | (mac disktable (var file)
1623 | `(fromdisk ,var ,file (table) load-table save-table))
1624 |
1625 | (mac todisk (var (o expr var))
1626 | `((savers* ',var)
1627 | ,(if (is var expr) var `(= ,var ,expr))))
1628 |
1629 |
1630 | (mac evtil (expr test)
1631 | (w/uniq gv
1632 | `(let ,gv ,expr
1633 | (while (no (,test ,gv))
1634 | (= ,gv ,expr))
1635 | ,gv)))
1636 |
1637 | (def rand-key (h)
1638 | (if (empty h)
1639 | nil
1640 | (let n (rand (len h))
1641 | (catch
1642 | (each (k v) h
1643 | (when (is (-- n) -1)
1644 | (throw k)))))))
1645 |
1646 | (def ratio (test xs)
1647 | (if (empty xs)
1648 | 0
1649 | (/ (count test xs) (len xs))))
1650 |
1651 |
1652 | ; any logical reason I can't say (push x (if foo y z)) ?
1653 | ; eval would have to always ret 2 things, the val and where it came from
1654 | ; idea: implicit tables of tables; setf empty field, becomes table
1655 | ; or should setf on a table just take n args?
1656 |
1657 | ; idea: use constants in functional position for currying?
1658 | ; (1 foo) would mean (fn args (apply foo 1 args))
1659 | ; another solution would be to declare certain symbols curryable, and
1660 | ; if > was, >_10 would mean [> _ 10]
1661 | ; or just say what the hell and make _ ssyntax for currying
1662 | ; idea: make >10 ssyntax for [> _ 10]
1663 | ; solution to the "problem" of improper lists: allow any atom as a list
1664 | ; terminator, not just nil. means list recursion should terminate on
1665 | ; atom rather than nil, (def empty (x) (or (atom x) (is x "")))
1666 | ; table should be able to take an optional initial-value. handle in sref.
1667 | ; warn about code of form (if (= )) -- probably mean is
1668 | ; warn when a fn has a parm that's already defined as a macro.
1669 | ; (def foo (after) (after))
1670 | ; idea: a fn (nothing) that returns a special gensym which is ignored
1671 | ; by map, so can use map in cases when don't want all the vals
1672 | ; idea: anaph macro so instead of (aand x y) say (anaph and x y)
1673 | ; idea: foo.bar!baz as an abbrev for (foo bar 'baz)
1674 | ; or something a bit more semantic?
1675 | ; could uniq be (def uniq () (annotate 'symbol (list 'u))) again?
1676 | ; idea: use x- for (car x) and -x for (cdr x) (but what about math -?)
1677 | ; idea: get rid of strings and just use symbols
1678 | ; could a string be (#\a #\b . "") ?
1679 | ; better err msg when , outside of a bq
1680 | ; idea: parameter (p foo) means in body foo is (pair arg)
1681 | ; idea: make ('string x) equiv to (coerce x 'string) ? or isa?
1682 | ; quoted atoms in car valuable unused semantic space
1683 | ; idea: if (defun foo (x y) ...), make (foo 1) return (fn (y) (foo 1 y))
1684 | ; probably would lead to lots of errors when call with missing args
1685 | ; but would be really dense with . notation, (foo.1 2)
1686 | ; or use special ssyntax for currying: (foo@1 2)
1687 | ; remember, can also double; could use foo::bar to mean something
1688 | ; wild idea: inline defs for repetitive code
1689 | ; same args as fn you're in
1690 | ; variant of compose where first fn only applied to first arg?
1691 | ; (> (len x) y) means (>+len x y)
1692 | ; use ssyntax underscore for a var?
1693 | ; foo_bar means [foo _ bar]
1694 | ; what does foo:_:bar mean?
1695 | ; matchcase
1696 | ; idea: atable that binds it to table, assumes input is a list
1697 | ; crazy that finding the top 100 nos takes so long:
1698 | ; (let bb (n-of 1000 (rand 50)) (time10 (bestn 100 > bb)))
1699 | ; time: 2237 msec. -> now down to 850 msec
1700 |
1701 |
--------------------------------------------------------------------------------
/arc3.1/array.arc:
--------------------------------------------------------------------------------
1 | ; inspired by http://awwx.ws/table-rw3
2 |
3 | (def parse-array-items (port (o acc nil))
4 | ((scheme skip-whitespace) port)
5 | (if (is (peekc port) #\])
6 | (do (readc port) `(list ,@(rev acc)))
7 | (let x (read port)
8 | (push x acc)
9 | (parse-array-items port acc))))
10 |
11 | (extend-readtable #\[ parse-array-items)
12 |
--------------------------------------------------------------------------------
/arc3.1/as.scm:
--------------------------------------------------------------------------------
1 | ; mzscheme -m -f as.scm
2 | ; (tl)
3 | ; (asv)
4 | ; http://localhost:8080
5 |
6 | (require mzscheme) ; promise we won't redefine mzscheme bindings
7 |
8 | (require "ac.scm")
9 | (require "brackets.scm")
10 | (use-bracket-readtable)
11 |
12 | (aload "arc.arc")
13 | (aload "libs.arc")
14 |
15 | (tl)
16 |
17 |
--------------------------------------------------------------------------------
/arc3.1/between0.arc:
--------------------------------------------------------------------------------
1 | ; http://awwx.ws/between0
2 |
3 | (mac between (var expr within . body)
4 | (w/uniq first
5 | `(let ,first t
6 | (each ,var ,expr
7 | (unless ,first ,within)
8 | (wipe ,first)
9 | ,@body))))
10 |
--------------------------------------------------------------------------------
/arc3.1/blog.arc:
--------------------------------------------------------------------------------
1 | ; Blog tool example. 20 Jan 08, rev 21 May 09.
2 |
3 | ; To run:
4 | ; arc> (load "blog.arc")
5 | ; arc> (bsv)
6 | ; go to http://localhost:8080/blog
7 |
8 | (= postdir* "arc/posts/" maxid* 0 posts* (table))
9 |
10 | (= blogtitle* "A Blog")
11 |
12 | (deftem post id nil title nil text nil)
13 |
14 | (def load-posts ()
15 | (each id (map int (dir postdir*))
16 | (= maxid* (max maxid* id)
17 | (posts* id) (temload 'post (string postdir* id)))))
18 |
19 | (def save-post (p) (save-table p (string postdir* p!id)))
20 |
21 | (def post (id) (posts* (errsafe:int id)))
22 |
23 | (mac blogpage body
24 | `(whitepage
25 | (center
26 | (widtable 600
27 | (tag b (link blogtitle* "blog"))
28 | (br 3)
29 | ,@body
30 | (br 3)
31 | (w/bars (link "archive")
32 | (link "new post" "newpost"))))))
33 |
34 | (defop viewpost req (blogop post-page req))
35 |
36 | (def blogop (f req)
37 | (aif (post (arg req "id"))
38 | (f (get-user req) it)
39 | (blogpage (pr "No such post."))))
40 |
41 | (def permalink (p) (string "viewpost?id=" p!id))
42 |
43 | (def post-page (user p) (blogpage (display-post user p)))
44 |
45 | (def display-post (user p)
46 | (tag b (link p!title (permalink p)))
47 | (when user
48 | (sp)
49 | (link "[edit]" (string "editpost?id=" p!id)))
50 | (br2)
51 | (pr p!text))
52 |
53 | (defopl newpost req
54 | (whitepage
55 | (aform [let u (get-user _)
56 | (post-page u (addpost u (arg _ "t") (arg _ "b")))]
57 | (tab (row "title" (input "t" "" 60))
58 | (row "text" (textarea "b" 10 80))
59 | (row "" (submit))))))
60 |
61 | (def addpost (user title text)
62 | (let p (inst 'post 'id (++ maxid*) 'title title 'text text)
63 | (save-post p)
64 | (= (posts* p!id) p)))
65 |
66 | (defopl editpost req (blogop edit-page req))
67 |
68 | (def edit-page (user p)
69 | (whitepage
70 | (vars-form user
71 | `((string title ,p!title t t) (text text ,p!text t t))
72 | (fn (name val) (= (p name) val))
73 | (fn () (save-post p)
74 | (post-page user p)))))
75 |
76 | (defop archive req
77 | (blogpage
78 | (tag ul
79 | (each p (map post (rev (range 1 maxid*)))
80 | (tag li (link p!title (permalink p)))))))
81 |
82 | (defop blog req
83 | (let user (get-user req)
84 | (blogpage
85 | (for i 0 4
86 | (awhen (posts* (- maxid* i))
87 | (display-post user it)
88 | (br 3))))))
89 |
90 | (def bsv ()
91 | (ensure-dir postdir*)
92 | (load-posts)
93 | (asv))
94 |
95 |
96 |
--------------------------------------------------------------------------------
/arc3.1/brackets.scm:
--------------------------------------------------------------------------------
1 | ; From Eli Barzilay, eli@barzilay.org
2 |
3 | ;> (require "brackets.scm")
4 | ;> (use-bracket-readtable)
5 | ;> ([+ _ 1] 10)
6 | ;11
7 |
8 | (module brackets mzscheme
9 |
10 | ; main reader function for []s
11 | ; recursive read starts with default readtable's [ parser,
12 | ; but nested reads still use the curent readtable:
13 |
14 | (define (read-square-brackets ch port src line col pos)
15 | `(fn (_)
16 | ,(read/recursive port #\[ #f)))
17 |
18 | ; a readtable that is just like the builtin except for []s
19 |
20 | (define bracket-readtable
21 | (make-readtable #f #\[ 'terminating-macro read-square-brackets))
22 |
23 | ; call this to set the global readtable
24 |
25 | (provide use-bracket-readtable)
26 |
27 | (define (use-bracket-readtable)
28 | (current-readtable bracket-readtable))
29 |
30 | ; these two implement the required functionality for #reader
31 |
32 | ;(define (*read inp)
33 | ; (parameterize ((current-readtable bracket-readtable))
34 | ; (read inp)))
35 |
36 | (define (*read . args)
37 | (parameterize ((current-readtable bracket-readtable))
38 | (read (if (null? args) (current-input-port) (car args)))))
39 |
40 | (define (*read-syntax src port)
41 | (parameterize ((current-readtable bracket-readtable))
42 | (read-syntax src port)))
43 |
44 | ; and the need to be provided as `read' and `read-syntax'
45 |
46 | (provide (rename *read read) (rename *read-syntax read-syntax))
47 |
48 | )
49 |
--------------------------------------------------------------------------------
/arc3.1/code.arc:
--------------------------------------------------------------------------------
1 | ; Code analysis. Spun off 21 Dec 07.
2 |
3 | ; Ought to do more of this in Arc. One of the biggest advantages
4 | ; of Lisp is messing with code.
5 |
6 | (def codelines (file)
7 | (w/infile in file
8 | (summing test
9 | (whilet line (readline in)
10 | (test (aand (find nonwhite line) (isnt it #\;)))))))
11 |
12 | (def codeflat (file)
13 | (len (flat (readall (infile file)))))
14 |
15 | (def codetree (file)
16 | (treewise + (fn (x) 1) (readall (infile file))))
17 |
18 | (def code-density (file)
19 | (/ (codetree file) (codelines file)))
20 |
21 | (def tokcount (files)
22 | (let counts (table)
23 | (each f files
24 | (each token (flat (readall (infile f)))
25 | (++ (counts token 0))))
26 | counts))
27 |
28 | (def common-tokens (files)
29 | (let counts (tokcount files)
30 | (let ranking nil
31 | (maptable (fn (k v)
32 | (unless (nonop k)
33 | (insort (compare > cadr) (list k v) ranking)))
34 | counts)
35 | ranking)))
36 |
37 | (def nonop (x)
38 | (in x 'quote 'unquote 'quasiquote 'unquote-splicing))
39 |
40 | (def common-operators (files)
41 | (keep [and (isa (car _) 'sym) (bound (car _))] (common-tokens files)))
42 |
43 | (def top40 (xs)
44 | (map prn (firstn 40 xs))
45 | t)
46 |
47 | (def space-eaters (files)
48 | (let counts (tokcount files)
49 | (let ranking nil
50 | (maptable (fn (k v)
51 | (when (and (isa k 'sym) (bound k))
52 | (insort (compare > [* (len (string (car _)))
53 | (cadr _)])
54 | (list k v (* (len (string k)) v))
55 | ranking)))
56 | counts)
57 | ranking)))
58 |
59 | ;(top40 (space-eaters allfiles*))
60 |
61 | (mac flatlen args `(len (flat ',args)))
62 |
--------------------------------------------------------------------------------
/arc3.1/copyright:
--------------------------------------------------------------------------------
1 | This software is copyright (c) Paul Graham and Robert Morris. Permission
2 | to use it is granted under the Perl Foundations's Artistic License 2.0.
3 |
--------------------------------------------------------------------------------
/arc3.1/extend-readtable0.arc:
--------------------------------------------------------------------------------
1 | ; http://awwx.ws/extend-readtable0
2 |
3 | (def extend-readtable (c parser)
4 | (scheme
5 | (current-readtable
6 | (make-readtable (current-readtable)
7 | c
8 | 'non-terminating-macro
9 | (lambda (ch port src line col pos)
10 | (parser port))))))
11 |
--------------------------------------------------------------------------------
/arc3.1/extend0.arc:
--------------------------------------------------------------------------------
1 | ; http://awwx.ws/extend0
2 |
3 | (mac extend (name arglist test . body)
4 | (w/uniq args
5 | `(let orig ,name
6 | (= ,name
7 | (fn ,args
8 | (aif (apply (fn ,arglist ,test) ,args)
9 | (apply (fn ,arglist ,@body) ,args)
10 | (apply orig ,args)))))))
11 |
--------------------------------------------------------------------------------
/arc3.1/how-to-run-news:
--------------------------------------------------------------------------------
1 | To run News:
2 |
3 | tar xvf arc3.1.tar
4 |
5 | cd arc3.1
6 |
7 | mkdir arc
8 |
9 | echo "myname" > arc/admins
10 |
11 | mzscheme -f as.scm
12 |
13 | at the arc prompt:
14 |
15 | (load "news.arc")
16 |
17 | (nsv)
18 |
19 | go to http://localhost:8080
20 |
21 | click on login, and create an account called myname
22 |
23 | you should now be logged in as an admin
24 |
25 | manually give at least 10 karma to your initial set of users
26 |
27 | don't worry about "user break" messages when restarting News
28 |
29 |
30 |
31 | To customize News:
32 |
33 | change the variables at the top of news.arc
34 |
35 |
36 |
37 | To improve performance:
38 |
39 | (= static-max-age* 7200) ; browsers can cache static files for 7200 sec
40 |
41 | (declare 'direct-calls t) ; you promise not to redefine fns as tables
42 |
43 | (declare 'explicit-flush t) ; you take responsibility for flushing output
44 | ; (all existing news code already does)
45 |
--------------------------------------------------------------------------------
/arc3.1/html.arc:
--------------------------------------------------------------------------------
1 | ; HTML Utils.
2 |
3 |
4 | (def color (r g b)
5 | (with (c (table)
6 | f (fn (x) (if (< x 0) 0 (> x 255) 255 x)))
7 | (= (c 'r) (f r) (c 'g) (f g) (c 'b) (f b))
8 | c))
9 |
10 | (def dehex (str) (errsafe (coerce str 'int 16)))
11 |
12 | (defmemo hex>color (str)
13 | (and (is (len str) 6)
14 | (with (r (dehex (cut str 0 2))
15 | g (dehex (cut str 2 4))
16 | b (dehex (cut str 4 6)))
17 | (and r g b
18 | (color r g b)))))
19 |
20 | (defmemo gray (n) (color n n n))
21 |
22 | (= white (gray 255)
23 | black (gray 0)
24 | linkblue (color 0 0 190)
25 | orange (color 255 102 0)
26 | darkred (color 180 0 0)
27 | darkblue (color 0 0 120)
28 | )
29 |
30 | (= opmeths* (table))
31 |
32 | (mac opmeth args
33 | `(opmeths* (list ,@args)))
34 |
35 | (mac attribute (tag opt f)
36 | `(= (opmeths* (list ',tag ',opt)) ,f))
37 |
38 | (= hexreps (table))
39 |
40 | (for i 0 255 (= (hexreps i)
41 | (let s (coerce i 'string 16)
42 | (if (is (len s) 1) (+ "0" s) s))))
43 |
44 | (defmemo hexrep (col)
45 | (+ (hexreps (col 'r)) (hexreps (col 'g)) (hexreps (col 'b))))
46 |
47 | (def opcolor (key val)
48 | (w/uniq gv
49 | `(whenlet ,gv ,val
50 | (pr ,(string " " key "=#") (hexrep ,gv)))))
51 |
52 | (def opstring (key val)
53 | `(aif ,val (pr ,(+ " " key "=\"") it #\")))
54 |
55 | (def opnum (key val)
56 | `(aif ,val (pr ,(+ " " key "=") it)))
57 |
58 | (def opsym (key val)
59 | `(pr ,(+ " " key "=") ,val))
60 |
61 | (def opsel (key val)
62 | `(if ,val (pr " selected")))
63 |
64 | (def opcheck (key val)
65 | `(if ,val (pr " checked")))
66 |
67 | (def opesc (key val)
68 | `(awhen ,val
69 | (pr ,(string " " key "=\""))
70 | (if (isa it 'string) (pr-escaped it) (pr it))
71 | (pr #\")))
72 |
73 | ; need to escape more? =?
74 |
75 | (def pr-escaped (x)
76 | (each c x
77 | (pr (case c #\< "<"
78 | #\> ">"
79 | #\" """
80 | #\& "&"
81 | c))))
82 |
83 | (attribute a href opstring)
84 | (attribute a rel opstring)
85 | (attribute a class opstring)
86 | (attribute a id opsym)
87 | (attribute a onclick opstring)
88 | (attribute body alink opcolor)
89 | (attribute body bgcolor opcolor)
90 | (attribute body leftmargin opnum)
91 | (attribute body link opcolor)
92 | (attribute body marginheight opnum)
93 | (attribute body marginwidth opnum)
94 | (attribute body topmargin opnum)
95 | (attribute body vlink opcolor)
96 | (attribute font color opcolor)
97 | (attribute font face opstring)
98 | (attribute font size opnum)
99 | (attribute form action opstring)
100 | (attribute form method opsym)
101 | (attribute img align opsym)
102 | (attribute img border opnum)
103 | (attribute img height opnum)
104 | (attribute img width opnum)
105 | (attribute img vspace opnum)
106 | (attribute img hspace opnum)
107 | (attribute img src opstring)
108 | (attribute input name opstring)
109 | (attribute input size opnum)
110 | (attribute input type opsym)
111 | (attribute input value opesc)
112 | (attribute input checked opcheck)
113 | (attribute select name opstring)
114 | (attribute option selected opsel)
115 | (attribute table bgcolor opcolor)
116 | (attribute table border opnum)
117 | (attribute table cellpadding opnum)
118 | (attribute table cellspacing opnum)
119 | (attribute table width opstring)
120 | (attribute textarea cols opnum)
121 | (attribute textarea name opstring)
122 | (attribute textarea rows opnum)
123 | (attribute textarea wrap opsym)
124 | (attribute td align opsym)
125 | (attribute td bgcolor opcolor)
126 | (attribute td colspan opnum)
127 | (attribute td width opnum)
128 | (attribute td valign opsym)
129 | (attribute td class opstring)
130 | (attribute tr bgcolor opcolor)
131 | (attribute hr color opcolor)
132 | (attribute span class opstring)
133 | (attribute span align opstring)
134 | (attribute span id opsym)
135 | (attribute rss version opstring)
136 |
137 |
138 | (mac gentag args (start-tag args))
139 |
140 | (mac tag (spec . body)
141 | `(do ,(start-tag spec)
142 | ,@body
143 | ,(end-tag spec)))
144 |
145 | (mac tag-if (test spec . body)
146 | `(if ,test
147 | (tag ,spec ,@body)
148 | (do ,@body)))
149 |
150 | (def start-tag (spec)
151 | (if (atom spec)
152 | `(pr ,(string "<" spec ">"))
153 | (let opts (tag-options (car spec) (pair (cdr spec)))
154 | (if (all [isa _ 'string] opts)
155 | `(pr ,(string "<" (car spec) (apply string opts) ">"))
156 | `(do (pr ,(string "<" (car spec)))
157 | ,@(map (fn (opt)
158 | (if (isa opt 'string)
159 | `(pr ,opt)
160 | opt))
161 | opts)
162 | (pr ">"))))))
163 |
164 | (def end-tag (spec)
165 | `(pr ,(string "")))
166 |
167 | (def literal (x)
168 | (case (type x)
169 | sym (in x nil t)
170 | cons (caris x 'quote)
171 | t))
172 |
173 | ; Returns a list whose elements are either strings, which can
174 | ; simply be printed out, or expressions, which when evaluated
175 | ; generate output.
176 |
177 | (def tag-options (spec options)
178 | (if (no options)
179 | '()
180 | (let ((opt val) . rest) options
181 | (let meth (if (is opt 'style) opstring (opmeth spec opt))
182 | (if meth
183 | (if val
184 | (cons (if (precomputable-tagopt val)
185 | (tostring (eval (meth opt val)))
186 | (meth opt val))
187 | (tag-options spec rest))
188 | (tag-options spec rest))
189 | (do
190 | (pr "")
191 | (tag-options spec rest)))))))
192 |
193 | (def precomputable-tagopt (val)
194 | (and (literal val)
195 | (no (and (is (type val) 'string) (find #\@ val)))))
196 |
197 | (def br ((o n 1))
198 | (repeat n (pr "
"))
199 | (prn))
200 |
201 | (def br2 () (prn "
"))
202 |
203 | (mac center body `(tag center ,@body))
204 | (mac underline body `(tag u ,@body))
205 | (mac tab body `(tag (table border 0) ,@body))
206 | (mac tr body `(tag tr ,@body))
207 |
208 | (let pratoms (fn (body)
209 | (if (or (no body)
210 | (all [and (acons _) (isnt (car _) 'quote)]
211 | body))
212 | body
213 | `((pr ,@body))))
214 |
215 | (mac td body `(tag td ,@(pratoms body)))
216 | (mac trtd body `(tr (td ,@(pratoms body))))
217 | (mac tdr body `(tag (td align 'right) ,@(pratoms body)))
218 | (mac tdcolor (col . body) `(tag (td bgcolor ,col) ,@(pratoms body)))
219 | )
220 |
221 | (mac row args
222 | `(tr ,@(map [list 'td _] args)))
223 |
224 | (mac prrow args
225 | (w/uniq g
226 | `(tr ,@(map (fn (a)
227 | `(let ,g ,a
228 | (if (number ,g)
229 | (tdr (pr ,g))
230 | (td (pr ,g)))))
231 | args))))
232 |
233 | (mac prbold body `(tag b (pr ,@body)))
234 |
235 | (def para args
236 | (gentag p)
237 | (when args (apply pr args)))
238 |
239 | (def menu (name items (o sel nil))
240 | (tag (select name name)
241 | (each i items
242 | (tag (option selected (is i sel))
243 | (pr i)))))
244 |
245 | (mac whitepage body
246 | `(tag html
247 | (tag (body bgcolor white alink linkblue) ,@body)))
248 |
249 | (def errpage args (whitepage (apply prn args)))
250 |
251 | (def blank-url () "s.gif")
252 |
253 | ; Could memoize these.
254 |
255 | ; If h = 0, doesn't affect table column widths in some Netscapes.
256 |
257 | (def hspace (n) (gentag img src (blank-url) height 1 width n))
258 | (def vspace (n) (gentag img src (blank-url) height n width 0))
259 | (def vhspace (h w) (gentag img src (blank-url) height h width w))
260 |
261 | (mac new-hspace (n)
262 | (if (number n)
263 | `(pr ,(string ""))
264 | `(pr "")))
265 |
266 | ;(def spacerow (h) (tr (td (vspace h))))
267 |
268 | (def spacerow (h) (pr "|
"))
269 |
270 | ; For use as nested table.
271 |
272 | (mac zerotable body
273 | `(tag (table border 0 cellpadding 0 cellspacing 0)
274 | ,@body))
275 |
276 | ; was `(tag (table border 0 cellpadding 0 cellspacing 7) ,@body)
277 |
278 | (mac sptab body
279 | `(tag (table style "border-spacing: 7px 0px;") ,@body))
280 |
281 | (mac widtable (w . body)
282 | `(tag (table width ,w) (tr (td ,@body))))
283 |
284 | (def cellpr (x) (pr (or x " ")))
285 |
286 | (def but ((o text "submit") (o name nil))
287 | (gentag input type 'submit name name value text))
288 |
289 | (def submit ((o val "submit"))
290 | (gentag input type 'submit value val))
291 |
292 | (def buts (name . texts)
293 | (if (no texts)
294 | (but)
295 | (do (but (car texts) name)
296 | (each text (cdr texts)
297 | (pr " ")
298 | (but text name)))))
299 |
300 | (mac spanrow (n . body)
301 | `(tr (tag (td colspan ,n) ,@body)))
302 |
303 | (mac form (action . body)
304 | `(tag (form method "post" action ,action) ,@body))
305 |
306 | (mac textarea (name rows cols . body)
307 | `(tag (textarea name ,name rows ,rows cols ,cols) ,@body))
308 |
309 | (def input (name (o val "") (o size 10))
310 | (gentag input type 'text name name value val size size))
311 |
312 | (mac inputs args
313 | `(tag (table border 0)
314 | ,@(map (fn ((name label len text))
315 | (w/uniq (gl gt)
316 | `(let ,gl ,len
317 | (tr (td (pr ',label ":"))
318 | (if (isa ,gl 'cons)
319 | (td (textarea ',name (car ,gl) (cadr ,gl)
320 | (let ,gt ,text (if ,gt (pr ,gt)))))
321 | (td (gentag input type ',(if (is label 'password)
322 | 'password
323 | 'text)
324 | name ',name
325 | size ,len
326 | value ,text)))))))
327 | (tuples args 4))))
328 |
329 | (def single-input (label name chars btext (o pwd))
330 | (pr label)
331 | (gentag input type (if pwd 'password 'text) name name size chars)
332 | (sp)
333 | (submit btext))
334 |
335 | (mac cdata body
336 | `(do (pr "")))
339 |
340 | (def eschtml (str)
341 | (tostring
342 | (each c str
343 | (pr (case c #\< "<"
344 | #\> ">"
345 | #\" """
346 | #\' "'"
347 | #\& "&"
348 | c)))))
349 |
350 | (def esc-tags (str)
351 | (tostring
352 | (each c str
353 | (pr (case c #\< "<"
354 | #\> ">"
355 | #\& "&"
356 | c)))))
357 |
358 | (def nbsp () (pr " "))
359 |
360 | (def link (text (o dest text) (o color))
361 | (tag (a href dest)
362 | (tag-if color (font color color)
363 | (pr text))))
364 |
365 | (def underlink (text (o dest text))
366 | (tag (a href dest) (tag u (pr text))))
367 |
368 | (def striptags (s)
369 | (let intag nil
370 | (tostring
371 | (each c s
372 | (if (is c #\<) (set intag)
373 | (is c #\>) (wipe intag)
374 | (no intag) (pr c))))))
375 |
376 | (def clean-url (u)
377 | (rem [in _ #\" #\' #\< #\>] u))
378 |
379 | (def shortlink (url)
380 | (unless (or (no url) (< (len url) 7))
381 | (link (cut url 7) url)))
382 |
383 | ; this should be one regexp
384 |
385 | (def parafy (str)
386 | (let ink nil
387 | (tostring
388 | (each c str
389 | (pr c)
390 | (unless (whitec c) (set ink))
391 | (when (is c #\newline)
392 | (unless ink (pr ""))
393 | (wipe ink))))))
394 |
395 | (mac spanclass (name . body)
396 | `(tag (span class ',name) ,@body))
397 |
398 | (def pagemessage (text)
399 | (when text (prn text) (br2)))
400 |
401 | ; Could be stricter. Memoized because looking for chars in Unicode
402 | ; strings is terribly inefficient in Mzscheme.
403 |
404 | (defmemo valid-url (url)
405 | (and (len> url 10)
406 | (or (begins url "http://")
407 | (begins url "https://"))
408 | (~find [in _ #\< #\> #\" #\'] url)))
409 |
410 | (mac fontcolor (c . body)
411 | (w/uniq g
412 | `(let ,g ,c
413 | (if ,g
414 | (tag (font color ,g) ,@body)
415 | (do ,@body)))))
416 |
--------------------------------------------------------------------------------
/arc3.1/js.arc:
--------------------------------------------------------------------------------
1 | (def butlast (xs)
2 | (firstn (- (len xs) 1) xs))
3 |
4 | ; '(a b c d . e) => '(a b c d e)
5 |
6 | (def nil-terminate (xs)
7 | (if (no xs)
8 | nil
9 | (and (cdr xs) (atom (cdr xs)))
10 | (cons (car xs) (cons (cdr xs) nil))
11 | (cons (car xs) (nil-terminate (cdr xs)))))
12 |
13 | (let nest-lev 0
14 |
15 | (def js-q ()
16 | (repeat nest-lev (pr #\\))
17 | (pr #\"))
18 |
19 | (def js-open-q ()
20 | (js-q)
21 | (= nest-lev (+ 1 (* 2 nest-lev))))
22 |
23 | (def js-close-q ()
24 | (= nest-lev (/ (- nest-lev 1) 2))
25 | (js-q)))
26 |
27 | (mac js-w/qs body
28 | `(do (js-open-q)
29 | ,@body
30 | (js-close-q)))
31 |
32 | (def js-quote (x)
33 | (if (acons x)
34 | (apply js-array x)
35 | (number x)
36 | (pr x)
37 | (js-w/qs (js1s x))))
38 |
39 | (def js-charesc (c)
40 | (case c #\newline (pr "\\n")
41 | #\tab (pr "\\t")
42 | #\return (pr "\\r")
43 | #\\ (pr "\\\\")
44 | #\' (js-q)
45 | (pr c)))
46 |
47 | ; an eachif would make conditional unnecessary
48 |
49 | (def js-str/charesc (c/s)
50 | (js-w/qs
51 | (if (isa c/s 'char) (js-charesc c/s)
52 | (isa c/s 'string) (each c c/s
53 | (js-charesc c)))))
54 |
55 | (def js-infix (op . args)
56 | (between a args (pr op)
57 | (js1s a)))
58 |
59 | (def js-infix-w/parens (op . args)
60 | (pr #\()
61 | (apply js-infix op args)
62 | (pr #\)))
63 |
64 | (def js-w/commas (xs)
65 | (apply js-infix #\, xs))
66 |
67 | (def js-obj args
68 | (pr #\{)
69 | (between (k v) (pair args) (pr #\,)
70 | (js1s k)
71 | (pr #\:)
72 | (js1s v))
73 | (pr #\}))
74 |
75 | (def js-array args
76 | (pr #\[)
77 | (js-w/commas args)
78 | (pr #\]))
79 |
80 | (def js-ref args
81 | (js1s (car args))
82 | (each a (cdr args)
83 | (pr #\[)
84 | (js1s a)
85 | (pr #\])))
86 |
87 | (def arglist (xs)
88 | (pr #\()
89 | (js-w/commas xs)
90 | (pr #\)))
91 |
92 | (def js-fncall (f . args)
93 | (js1s f)
94 | (arglist args))
95 |
96 | (def js-call1 (x arg)
97 | (if (and (acons arg) (is (car arg) 'quasiquote))
98 | (js-ref x (cons 'quote (cdr arg)))
99 | (js-fncall x arg)))
100 |
101 | (def js-call (x . arg/s)
102 | (if (single arg/s)
103 | (apply js-call1 x arg/s)
104 | (apply js-fncall x arg/s)))
105 |
106 | (def js-new (C . args)
107 | (pr "new ")
108 | (js1s `(,C ,@args)))
109 |
110 | (def js-typeof args
111 | (pr "typeof ")
112 | (each a args
113 | (js1s a)))
114 |
115 | ; bad name when everything is an expression
116 |
117 | (def retblock (exprs)
118 | (pr #\{
119 | "return ")
120 | (js-w/commas exprs)
121 | (pr #\; #\}))
122 |
123 | (def js-fn (args . body)
124 | (pr #\( "function")
125 | (if (no args)
126 | (do (arglist nil)
127 | (retblock body))
128 | (atom args)
129 | (do (arglist nil)
130 | (retblock
131 | (cons `(= ,args
132 | (Array.prototype.slice.call
133 | arguments))
134 | body)))
135 | (dotted args)
136 | (let args1 (nil-terminate args)
137 | (arglist (butlast args1))
138 | (retblock
139 | (cons `(= ,(last args1)
140 | (Array.prototype.slice.call
141 | arguments
142 | ,(- (len args1) 1)))
143 | body)))
144 | (do (arglist args)
145 | (retblock body)))
146 | (pr #\)))
147 |
148 | (def js-if args
149 | (pr #\()
150 | (js1s (car args))
151 | (each (then else) (pair (cdr args))
152 | (pr #\?)
153 | (js1s then)
154 | (pr #\:)
155 | (js1s else))
156 | (pr #\)))
157 |
158 | (def js-= args
159 | (between (var val) (pair args) (pr #\,)
160 | (js1s var)
161 | (pr #\=)
162 | (js1s val)))
163 |
164 | (def js-do exprs
165 | (pr #\()
166 | (js-w/commas exprs)
167 | (pr #\)))
168 |
169 | (def js-while (test . body)
170 | (pr "(function(){"
171 | "while(") (js1s test) (pr "){")
172 | (apply js-do body)
173 | (pr "}"
174 | "}).call(this)"))
175 |
176 | (= js-macs* (table))
177 |
178 | (mac js-mac (name args . body)
179 | `(= (js-macs* ',name) (fn ,args (js1s ,@body))))
180 |
181 | (def js1 (s)
182 | (if (caris s 'quote) (apply js-quote (cdr s))
183 | (or (isa s 'char)
184 | (isa s 'string)) (js-str/charesc s)
185 | (no s) (pr 'null)
186 | (atom s) (pr s)
187 | (in (car s) '+ '-
188 | '* '/ '>= '<=
189 | '> '< '% '==
190 | '=== '!= '!==
191 | '+= '-= '*= '/=
192 | '%= '&& '\|\|
193 | '\,) (apply js-infix-w/parens s)
194 | (or (caris s '\.)
195 | (caris s '..)) (apply js-infix (cons '|.| (cdr s)))
196 | (caris s 'list) (apply js-array (cdr s))
197 | (caris s 'obj) (apply js-obj (cdr s))
198 | (caris s 'ref) (apply js-ref (cdr s))
199 | (caris s 'new) (apply js-new (cdr s))
200 | (caris s 'typeof) (apply js-typeof (cdr s))
201 | (caris s 'do) (apply js-do (cdr s))
202 | (caris s 'if) (apply js-if (cdr s))
203 | (caris s 'fn) (apply js-fn (cdr s))
204 | (caris s '=) (apply js-= (cdr s))
205 | (caris s 'while) (apply js-while (cdr s))
206 | (caris s 'mac) (eval `(js-mac ,@(cdr s)))
207 | (js-macs* (car s)) (apply (js-macs* (car s)) (cdr s))
208 | (apply js-call s)))
209 |
210 | (def js1s args
211 | (between a args (pr #\,)
212 | (js1 a)))
213 |
214 | (def js-repl ()
215 | (pr "sweet> ")
216 | (let expr (read)
217 | (if (iso expr '(sour))
218 | (do (prn "Bye!") nil)
219 | (do (js expr) (js-repl)))))
220 |
221 | (def js args
222 | (if (no args)
223 | (do (prn "Welcome to SweetScript! Type (sour) to leave.")
224 | (js-repl))
225 | (do (apply js1s args)
226 | (prn #\;))))
227 |
228 | ; js alias
229 | (def sweet args (apply js args))
230 |
231 | ; macros
232 |
233 | (js `(do
234 |
235 | (mac let (var val . body)
236 | (w/uniq gvar
237 | `(do (= ,gvar ,val)
238 | ,@(tree-subst var gvar body))))
239 |
240 | (mac with (parms . body)
241 | (if (no parms)
242 | `(do ,@body)
243 | `(let ,(car parms) ,(cadr parms)
244 | (with ,(cddr parms) ,@body))))
245 |
246 | (mac when (test . body)
247 | `(if ,test (do ,@body)))
248 |
249 | (mac unless (test . body)
250 | `(if (! ,test) (do ,@body)))
251 |
252 | (mac until (test . body)
253 | `(while (! ,test) ,@body))
254 |
255 | (mac def (name parms . body)
256 | `(= ,name (fn ,parms ,@body)))
257 |
258 | ; html templating system inspired by html.arc
259 | ;
260 | ; sweet> (tag input (type "text")
261 | ; (tag ul ()
262 | ; (tag li () "apples")
263 | ; (tag li () "bananas")))
264 | ; (('<'+'input'+' '+('type'+'='+'\'text\''+' ')+'>')+(('<'+'ul'+'>')+(('<'+'li'+'>')+'apples'+(''))+(('<'+'li'+'>')+'bananas'+(''))+(''))+(''));
265 |
266 | (mac parse-attrs (attrs)
267 | (let acc nil
268 | (each (k v) (pair attrs)
269 | (= acc (+ acc `(',k "=" ',v " "))))
270 | (push '+ acc)
271 | acc))
272 |
273 | (mac start-tag (spec attrs)
274 | (if (no attrs)
275 | `(+ "<" ',spec ">")
276 | `(+ "<" ',spec " " (parse-attrs ,attrs) ">")))
277 |
278 | (mac end-tag (spec)
279 | `(+ ""))
280 |
281 | (mac tag (spec attrs . body)
282 | `(+ (start-tag ,spec ,attrs)
283 | ,@body
284 | (end-tag ,spec)))
285 |
286 | ; jQuery helper macro
287 | ; Example usage: ($ "p.neat"
288 | ; (addClass "ohmy")
289 | ; (show "slow"))
290 |
291 | (mac $ (selector . args)
292 | `(.. (jQuery ,selector) ,@args))
293 |
294 | ; Examples from http://documentcloud.github.com/underscore/#styles
295 |
296 | ; Collections
297 |
298 | (_.each [1 2 3] (fn (x) (alert x)))
299 | (_.each {one 1 two 2 three 3} (fn (x) (alert x)))
300 |
301 | (_.map [1 2 3] (fn (x) (* x 3)))
302 | (_.map {one 1 two 2 three 3} (fn (x) (* x 3)))
303 |
304 | (= sum (_.reduce [1 2 3] (fn (memo x) (+ memo x)) 0))
305 |
306 | (= list [[0 1] [2 3] [4 5]]
307 | flat (_.reduceRight list (fn (a b) (.. a (concat b))) []))
308 |
309 | (= even (_.detect [1 2 3 4 5 6] (fn (x) (== (% x 2) 0))))
310 |
311 | ; alias select
312 | (= evens (_.filter [1 2 3 4 5 6] (fn (x) (== (% x 2) 0))))
313 |
314 | (= odds (_.reject [1 2 3 4 5 6] (fn (x) (== (% x 2) 0))))
315 |
316 | (_.all [true 1 null "yes"])
317 |
318 | (_.any [true 1 null "yes"])
319 |
320 | (_.include [1 2 3] 3)
321 |
322 | (_.invoke [[5 1 7] [3 2 1]] "sort")
323 |
324 | (let stooges [{name "moe" age 40} {name "larry" age 50}
325 | {name "curly" age 60}]
326 | (_.pluck stooges "name"))
327 |
328 | (let stooges [{name "moe" age 40} {name "larry" age 50}
329 | {name "curly" age 60}]
330 | (_.max stooges (fn (stooge) stooge.age)))
331 |
332 | (let numbers [10 5 100 2 1000]
333 | (_.min numbers))
334 |
335 | (_.sortBy [1 2 3 4 5 6] (fn (x) (Math.sin x)))
336 |
337 | (_.sortedIndex [10 20 30 40 50] 35)
338 |
339 | ((fn () (_.toArray arguments (slice 0))) 1 2 3)
340 |
341 | (_.size {one 1 two 2 three 3})
342 |
343 | ; Function (uh, ahem) Functions
344 |
345 | (let f (fn (greeting)
346 | (+ greeting ": " this.name))
347 | (= f (_.bind f {name "moe"} "hi"))
348 | (f))
349 |
350 | ; Example program
351 | ; Compiled output goes in static/sweet-example.js, which
352 | ; is linked to from static/sweet-example.html
353 | ; Depends on underscore.js and jQuery
354 |
355 | (do
356 |
357 | (= xs [])
358 |
359 | (def render ()
360 | ($ "#xs" (empty))
361 | (_.each xs (fn (x)
362 | ($ "#xs" (append (tag div () x))))))
363 |
364 | ($ (tag input ())
365 | (change (fn ()
366 | (xs.unshift ($ this (val)))
367 | ($ this (val ""))
368 | (render)))
369 | (appendTo "body"))
370 |
371 | ($ (tag div (id "xs"))
372 | (appendTo "body")))
373 |
374 |
375 | ))
376 |
--------------------------------------------------------------------------------
/arc3.1/libs.arc:
--------------------------------------------------------------------------------
1 | (map load '("strings.arc"
2 | "pprint.arc"
3 | "code.arc"
4 | "html.arc"
5 | "srv.arc"
6 | "app.arc"
7 | "prompt.arc"
8 |
9 | "extend0.arc"
10 | "scheme0.arc"
11 | "extend-readtable0.arc"
12 |
13 | "skipwhite1.arc"
14 | "table-rw3.arc"
15 | "array.arc"
16 |
17 | "between0.arc"
18 |
19 | "js.arc"
20 | ))
21 |
--------------------------------------------------------------------------------
/arc3.1/person.arc:
--------------------------------------------------------------------------------
1 | ; sweet-script example
2 | ; hacking with ryan, 12/28/10
3 |
4 | (js `(do
5 |
6 |
7 | (def personUpdateStern ()
8 | (if (== this.laughter 0)
9 | (= this.stern true)
10 | (> this.laughter 5)
11 | (= this.stern))
12 | this.stern)
13 |
14 | (def personUpdateLaughter ()
15 | (if (! this.stern)
16 | (+= this.laughter 10)
17 | (do (-- this.laughter)
18 | (if (< this.laughter -10)
19 | (+= this.laughter 10000))))
20 | this.stern)
21 |
22 | (def person ()
23 | {laughter 0
24 | stern false
25 | updateStern personUpdateStern
26 | updateLaughter personUpdateLaughter})
27 |
28 | (= evan (person) ryan (person))
29 |
30 |
31 | ))
32 |
--------------------------------------------------------------------------------
/arc3.1/pprint.arc:
--------------------------------------------------------------------------------
1 | ; Pretty-Printing. Spun off 4 Aug 06.
2 |
3 | ; todo: indentation of long ifs; quasiquote, unquote, unquote-splicing
4 |
5 | (= bodops* (fill-table (table)
6 | '(let 2 with 1 while 1 def 2 fn 1 rfn 2 afn 1
7 | when 1 unless 1 after 1 whilet 2 for 3 each 2 whenlet 2 awhen 1
8 | whitepage 0 tag 1 form 1 aform 1 aformh 1 w/link 1 textarea 3
9 | )))
10 |
11 | (= oneline* 35) ; print exprs less than this long on one line
12 |
13 | ; If returns nil, can assume it didn't have to break expr.
14 |
15 | (def ppr (expr (o col 0) (o noindent nil))
16 | (if (or (atom expr) (dotted expr))
17 | (do (unless noindent (sp col))
18 | (write expr)
19 | nil)
20 | (is (car expr) 'quote)
21 | (do (unless noindent (sp col))
22 | (pr "'")
23 | (ppr (cadr expr) (+ col 1) t))
24 | (bodops* (car expr))
25 | (do (unless noindent (sp col))
26 | (let whole (tostring (write expr))
27 | (if (< (len whole) oneline*)
28 | (do (pr whole) nil)
29 | (ppr-progn expr col noindent))))
30 | (do (unless noindent (sp col))
31 | (let whole (tostring (write expr))
32 | (if (< (len whole) oneline*)
33 | (do (pr whole) nil)
34 | (ppr-call expr col noindent))))))
35 |
36 | (def ppr-progn (expr col noindent)
37 | (lpar)
38 | (let n (bodops* (car expr))
39 | (let str (tostring (write-spaced (firstn n expr)))
40 | (unless (is n 0) (pr str) (sp))
41 | (ppr (expr n) (+ col (len str) 2) t))
42 | (map (fn (e) (prn) (ppr e (+ col 2)))
43 | (nthcdr (+ n 1) expr)))
44 | (rpar)
45 | t)
46 |
47 | (def ppr-call (expr col noindent)
48 | (lpar)
49 | (let carstr (tostring (write (car expr)))
50 | (pr carstr)
51 | (if (cdr expr)
52 | (do (sp)
53 | (let broke (ppr (cadr expr) (+ col (len carstr) 2) t)
54 | (pprest (cddr expr)
55 | (+ col (len carstr) 2)
56 | (no broke)))
57 | t)
58 | (do (rpar) t))))
59 |
60 | (def pprest (exprs col (o oneline t))
61 | (if (and oneline
62 | (all (fn (e)
63 | (or (atom e) (and (is (car e) 'quote) (atom (cadr e)))))
64 | exprs))
65 | (do (map (fn (e) (pr " ") (write e))
66 | exprs)
67 | (rpar))
68 | (do (when exprs
69 | (each e exprs (prn) (ppr e col)))
70 | (rpar))))
71 |
72 | (def write-spaced (xs)
73 | (when xs
74 | (write (car xs))
75 | (each x (cdr xs) (pr " ") (write x))))
76 |
77 | (def sp ((o n 1)) (repeat n (pr " ")))
78 | (def lpar () (pr "("))
79 | (def rpar () (pr ")"))
80 |
81 |
--------------------------------------------------------------------------------
/arc3.1/prompt.arc:
--------------------------------------------------------------------------------
1 | ; Prompt: Web-based programming application. 4 Aug 06.
2 |
3 | (= appdir* "arc/apps/")
4 |
5 | (defop prompt req
6 | (let user (get-user req)
7 | (if (admin user)
8 | (prompt-page user)
9 | (pr "Sorry."))))
10 |
11 | (def prompt-page (user . msg)
12 | (ensure-dir appdir*)
13 | (ensure-dir (string appdir* user))
14 | (whitepage
15 | (prbold "Prompt")
16 | (hspace 20)
17 | (pr user " | ")
18 | (link "logout")
19 | (when msg (hspace 10) (apply pr msg))
20 | (br2)
21 | (tag (table border 0 cellspacing 10)
22 | (each app (dir (+ appdir* user))
23 | (tr (td app)
24 | (td (ulink user 'edit (edit-app user app)))
25 | (td (ulink user 'run (run-app user app)))
26 | (td (hspace 40)
27 | (ulink user 'delete (rem-app user app))))))
28 | (br2)
29 | (aform (fn (req)
30 | (when-umatch user req
31 | (aif (goodname (arg req "app"))
32 | (edit-app user it)
33 | (prompt-page user "Bad name."))))
34 | (tab (row "name:" (input "app") (submit "create app"))))))
35 |
36 | (def app-path (user app)
37 | (and user app (+ appdir* user "/" app)))
38 |
39 | (def read-app (user app)
40 | (aand (app-path user app)
41 | (file-exists it)
42 | (readfile it)))
43 |
44 | (def write-app (user app exprs)
45 | (awhen (app-path user app)
46 | (w/outfile o it
47 | (each e exprs (write e o)))))
48 |
49 | (def rem-app (user app)
50 | (let file (app-path user app)
51 | (if (file-exists file)
52 | (do (rmfile (app-path user app))
53 | (prompt-page user "Program " app " deleted."))
54 | (prompt-page user "No such app."))))
55 |
56 | (def edit-app (user app)
57 | (whitepage
58 | (pr "user: " user " app: " app)
59 | (br2)
60 | (aform (fn (req)
61 | (let u2 (get-user req)
62 | (if (is u2 user)
63 | (do (when (is (arg req "cmd") "save")
64 | (write-app user app (readall (arg req "exprs"))))
65 | (prompt-page user))
66 | (login-page 'both nil
67 | (fn (u ip) (prompt-page u))))))
68 | (textarea "exprs" 10 82
69 | (pprcode (read-app user app)))
70 | (br2)
71 | (buts 'cmd "save" "cancel"))))
72 |
73 | (def pprcode (exprs)
74 | (each e exprs
75 | (ppr e)
76 | (pr "\n\n")))
77 |
78 | (def view-app (user app)
79 | (whitepage
80 | (pr "user: " user " app: " app)
81 | (br2)
82 | (tag xmp (pprcode (read-app user app)))))
83 |
84 | (def run-app (user app)
85 | (let exprs (read-app user app)
86 | (if exprs
87 | (on-err (fn (c) (pr "Error: " (details c)))
88 | (fn () (map eval exprs)))
89 | (prompt-page user "Error: No application " app " for user " user))))
90 |
91 | (wipe repl-history*)
92 |
93 | (defop repl req
94 | (if (admin (get-user req))
95 | (replpage req)
96 | (pr "Sorry.")))
97 |
98 | (def replpage (req)
99 | (whitepage
100 | (repl (readall (or (arg req "expr") "")) "repl")))
101 |
102 | (def repl (exprs url)
103 | (each expr exprs
104 | (on-err (fn (c) (push (list expr c t) repl-history*))
105 | (fn ()
106 | (= that (eval expr) thatexpr expr)
107 | (push (list expr that) repl-history*))))
108 | (form url
109 | (textarea "expr" 8 60)
110 | (sp)
111 | (submit))
112 | (tag xmp
113 | (each (expr val err) (firstn 20 repl-history*)
114 | (pr "> ")
115 | (ppr expr)
116 | (prn)
117 | (prn (if err "Error: " "")
118 | (ellipsize (tostring (write val)) 800)))))
119 |
120 |
--------------------------------------------------------------------------------
/arc3.1/scheme0.arc:
--------------------------------------------------------------------------------
1 | ; http://awwx.ws/scheme0
2 | ; modified!
3 |
4 | (extend ac (s env) (and (errsafe:acons s) (is (car s) 'scheme))
5 | `(begin ,@(cdr s)))
6 |
7 | (= ac-denil (scheme ac-denil))
8 | (= ac-global-name (scheme ac-global-name))
9 | (= ac-niltree (scheme ac-niltree))
10 |
11 | (mac ac-set-global (name val)
12 | (w/uniq (gname v)
13 | `(with (,gname (ac-global-name ,name)
14 | ,v ,val)
15 | (scheme (namespace-set-variable-value! ,gname ,v))
16 | nil)))
17 |
18 | (= scheme-f (read "#f"))
19 | (= scheme-t (read "#t"))
20 |
--------------------------------------------------------------------------------
/arc3.1/skipwhite1.arc:
--------------------------------------------------------------------------------
1 | ; place in own library to abide by the LGPL
2 | ;
3 | ; skip-whitespace is copied from
4 | ; http://download.plt-scheme.org/doc/352/html/mzscheme/mzscheme-Z-H-11.html#node_sec_11.2.8
5 | ; which has the following licence:
6 | ;
7 | ; Copyright ©1995-2006 Matthew Flatt
8 | ;
9 | ; Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Library General Public License, Version 2 published by the Free Software Foundation.
10 | ;
11 | ; [ ] in source changed to ( ) to avoid conflict with brackets.scm
12 |
13 | (scheme:define (skip-whitespace port)
14 | ;; Skips whitespace characters, sensitive to the current
15 | ;; readtable's definition of whitespace
16 | (let ((ch (peek-char port)))
17 | (unless (eof-object? ch)
18 | ;; Consult current readtable:
19 | (let-values (((like-ch/sym proc dispatch-proc)
20 | (readtable-mapping (current-readtable) ch)))
21 | ;; If like-ch/sym is whitespace, then ch is whitespace
22 | (when (and (char? like-ch/sym)
23 | (char-whitespace? like-ch/sym))
24 | (read-char port)
25 | (skip-whitespace port))))))
26 |
--------------------------------------------------------------------------------
/arc3.1/srv.arc:
--------------------------------------------------------------------------------
1 | ; HTTP Server.
2 |
3 | ; To improve performance with static files, set static-max-age*.
4 |
5 | (= arcdir* "arc/" logdir* "arc/logs/" staticdir* "static/")
6 |
7 | (= quitsrv* nil breaksrv* nil)
8 |
9 | (def serve ((o port 8080))
10 | (wipe quitsrv*)
11 | (ensure-srvdirs)
12 | (map [apply new-bgthread _] pending-bgthreads*)
13 | (w/socket s port
14 | (setuid 2) ; XXX switch from root to pg
15 | (prn "ready to serve port " port)
16 | (flushout)
17 | (= currsock* s)
18 | (until quitsrv*
19 | (handle-request s breaksrv*)))
20 | (prn "quit server"))
21 |
22 | (def serve1 ((o port 8080))
23 | (w/socket s port (handle-request s t)))
24 |
25 | (def ensure-srvdirs ()
26 | (map ensure-dir (list arcdir* logdir* staticdir*)))
27 |
28 | (= srv-noisy* nil)
29 |
30 | ; http requests currently capped at 2 meg by socket-accept
31 |
32 | ; should threads process requests one at a time? no, then
33 | ; a browser that's slow consuming the data could hang the
34 | ; whole server.
35 |
36 | ; wait for a connection from a browser and start a thread
37 | ; to handle it. also arrange to kill that thread if it
38 | ; has not completed in threadlife* seconds.
39 |
40 | (= threadlife* 30 requests* 0 requests/ip* (table)
41 | throttle-ips* (table) ignore-ips* (table) spurned* (table))
42 |
43 | (def handle-request (s breaksrv)
44 | (if breaksrv
45 | (handle-request-1 s)
46 | (errsafe (handle-request-1 s))))
47 |
48 | (def handle-request-1 (s)
49 | (let (i o ip) (socket-accept s)
50 | (if (and (or (ignore-ips* ip) (abusive-ip ip))
51 | (++ (spurned* ip 0)))
52 | (force-close i o)
53 | (do (++ requests*)
54 | (++ (requests/ip* ip 0))
55 | (with (th1 nil th2 nil)
56 | (= th1 (thread
57 | (after (handle-request-thread i o ip)
58 | (close i o)
59 | (kill-thread th2))))
60 | (= th2 (thread
61 | (sleep threadlife*)
62 | (unless (dead th1)
63 | (prn "srv thread took too long for " ip))
64 | (break-thread th1)
65 | (force-close i o))))))))
66 |
67 | ; Returns true if ip has made req-limit* requests in less than
68 | ; req-window* seconds. If an ip is throttled, only 1 request is
69 | ; allowed per req-window* seconds. If an ip makes req-limit*
70 | ; requests in less than dos-window* seconds, it is a treated as a DoS
71 | ; attack and put in ignore-ips* (for this server invocation).
72 |
73 | ; To adjust this while running, adjust the req-window* time, not
74 | ; req-limit*, because algorithm doesn't enforce decreases in the latter.
75 |
76 | (= req-times* (table) req-limit* 30 req-window* 10 dos-window* 2)
77 |
78 | (def abusive-ip (ip)
79 | (and (only.> (requests/ip* ip) 250)
80 | (let now (seconds)
81 | (do1 (if (req-times* ip)
82 | (and (>= (qlen (req-times* ip))
83 | (if (throttle-ips* ip) 1 req-limit*))
84 | (let dt (- now (deq (req-times* ip)))
85 | (if (< dt dos-window*) (set (ignore-ips* ip)))
86 | (< dt req-window*)))
87 | (do (= (req-times* ip) (queue))
88 | nil))
89 | (enq now (req-times* ip))))))
90 |
91 | (def handle-request-thread (i o ip)
92 | (with (nls 0 lines nil line nil responded nil t0 (msec))
93 | (after
94 | (whilet c (unless responded (readc i))
95 | (if srv-noisy* (pr c))
96 | (if (is c #\newline)
97 | (if (is (++ nls) 2)
98 | (let (type op args n cooks) (parseheader (rev lines))
99 | (let t1 (msec)
100 | (case type
101 | get (respond o op args cooks ip)
102 | post (handle-post i o op args n cooks ip)
103 | (respond-err o "Unknown request: " (car lines)))
104 | (log-request type op args cooks ip t0 t1)
105 | (set responded)))
106 | (do (push (string (rev line)) lines)
107 | (wipe line)))
108 | (unless (is c #\return)
109 | (push c line)
110 | (= nls 0))))
111 | (close i o)))
112 | (harvest-fnids))
113 |
114 | (def log-request (type op args cooks ip t0 t1)
115 | (with (parsetime (- t1 t0) respondtime (- (msec) t1))
116 | (srvlog 'srv ip
117 | parsetime
118 | respondtime
119 | (if (> (+ parsetime respondtime) 1000) "***" "")
120 | type
121 | op
122 | (let arg1 (car args)
123 | (if (caris arg1 "fnid") "" arg1))
124 | cooks)))
125 |
126 | ; Could ignore return chars (which come from textarea fields) here by
127 | ; (unless (is c #\return) (push c line))
128 |
129 | (def handle-post (i o op args n cooks ip)
130 | (if srv-noisy* (pr "Post Contents: "))
131 | (if (no n)
132 | (respond-err o "Post request without Content-Length.")
133 | (let line nil
134 | (whilet c (and (> n 0) (readc i))
135 | (if srv-noisy* (pr c))
136 | (-- n)
137 | (push c line))
138 | (if srv-noisy* (pr "\n\n"))
139 | (respond o op (+ (parseargs (string (rev line))) args) cooks ip))))
140 |
141 | (= header* "HTTP/1.1 200 OK
142 | Content-Type: text/html; charset=utf-8
143 | Connection: close")
144 |
145 | (= type-header* (table))
146 |
147 | (def gen-type-header (ctype)
148 | (+ "HTTP/1.0 200 OK
149 | Content-Type: "
150 | ctype
151 | "
152 | Connection: close"))
153 |
154 | (map (fn ((k v)) (= (type-header* k) (gen-type-header v)))
155 | '((gif "image/gif")
156 | (jpg "image/jpeg")
157 | (png "image/png")
158 | (text/html "text/html; charset=utf-8")))
159 |
160 | (= rdheader* "HTTP/1.0 302 Moved")
161 |
162 | (= srvops* (table) redirector* (table) optimes* (table) opcounts* (table))
163 |
164 | (def save-optime (name elapsed)
165 | ; this is the place to put a/b testing
166 | ; toggle a flag and push elapsed into one of two lists
167 | (++ (opcounts* name 0))
168 | (unless (optimes* name) (= (optimes* name) (queue)))
169 | (enq-limit elapsed (optimes* name) 1000))
170 |
171 | ; For ops that want to add their own headers. They must thus remember
172 | ; to prn a blank line before anything meant to be part of the page.
173 |
174 | (mac defop-raw (name parms . body)
175 | (w/uniq t1
176 | `(= (srvops* ',name)
177 | (fn ,parms
178 | (let ,t1 (msec)
179 | (do1 (do ,@body)
180 | (save-optime ',name (- (msec) ,t1))))))))
181 |
182 | (mac defopr-raw (name parms . body)
183 | `(= (redirector* ',name) t
184 | (srvops* ',name) (fn ,parms ,@body)))
185 |
186 | (mac defop (name parm . body)
187 | (w/uniq gs
188 | `(do (wipe (redirector* ',name))
189 | (defop-raw ,name (,gs ,parm)
190 | (w/stdout ,gs (prn) ,@body)))))
191 |
192 | ; Defines op as a redirector. Its retval is new location.
193 |
194 | (mac defopr (name parm . body)
195 | (w/uniq gs
196 | `(do (set (redirector* ',name))
197 | (defop-raw ,name (,gs ,parm)
198 | ,@body))))
199 |
200 | ;(mac testop (name . args) `((srvops* ',name) ,@args))
201 |
202 | (deftem request
203 | args nil
204 | cooks nil
205 | ip nil)
206 |
207 | (= unknown-msg* "Unknown." max-age* (table) static-max-age* nil)
208 |
209 | (def respond (str op args cooks ip)
210 | (w/stdout str
211 | (iflet f (srvops* op)
212 | (let req (inst 'request 'args args 'cooks cooks 'ip ip)
213 | (if (redirector* op)
214 | (do (prn rdheader*)
215 | (prn "Location: " (f str req))
216 | (prn))
217 | (do (prn header*)
218 | (awhen (max-age* op)
219 | (prn "Cache-Control: max-age=" it))
220 | (f str req))))
221 | (let filetype (static-filetype op)
222 | (aif (and filetype (file-exists (string staticdir* op)))
223 | (do (prn (type-header* filetype))
224 | (awhen static-max-age*
225 | (prn "Cache-Control: max-age=" it))
226 | (prn)
227 | (w/infile i it
228 | (whilet b (readb i)
229 | (writeb b str))))
230 | (respond-err str unknown-msg*))))))
231 |
232 | (def static-filetype (sym)
233 | (let fname (coerce sym 'string)
234 | (and (~find #\/ fname)
235 | (case (downcase (last (check (tokens fname #\.) ~single)))
236 | "gif" 'gif
237 | "jpg" 'jpg
238 | "jpeg" 'jpg
239 | "png" 'png
240 | "css" 'text/html
241 | "txt" 'text/html
242 | "htm" 'text/html
243 | "html" 'text/html
244 | "arc" 'text/html
245 | ))))
246 |
247 | (def respond-err (str msg . args)
248 | (w/stdout str
249 | (prn header*)
250 | (prn)
251 | (apply pr msg args)))
252 |
253 | (def parseheader (lines)
254 | (let (type op args) (parseurl (car lines))
255 | (list type
256 | op
257 | args
258 | (and (is type 'post)
259 | (some (fn (s)
260 | (and (begins s "Content-Length:")
261 | (errsafe:coerce (cadr (tokens s)) 'int)))
262 | (cdr lines)))
263 | (some (fn (s)
264 | (and (begins s "Cookie:")
265 | (parsecookies s)))
266 | (cdr lines)))))
267 |
268 | ; (parseurl "GET /p1?foo=bar&ug etc") -> (get p1 (("foo" "bar") ("ug")))
269 |
270 | (def parseurl (s)
271 | (let (type url) (tokens s)
272 | (let (base args) (tokens url #\?)
273 | (list (sym (downcase type))
274 | (sym (cut base 1))
275 | (if args
276 | (parseargs args)
277 | nil)))))
278 |
279 | ; I don't urldecode field names or anything in cookies; correct?
280 |
281 | (def parseargs (s)
282 | (map (fn ((k v)) (list k (urldecode v)))
283 | (map [tokens _ #\=] (tokens s #\&))))
284 |
285 | (def parsecookies (s)
286 | (map [tokens _ #\=]
287 | (cdr (tokens s [or (whitec _) (is _ #\;)]))))
288 |
289 | (def arg (req key) (alref req!args key))
290 |
291 | ; *** Warning: does not currently urlencode args, so if need to do
292 | ; that replace v with (urlencode v).
293 |
294 | (def reassemble-args (req)
295 | (aif req!args
296 | (apply string "?" (intersperse '&
297 | (map (fn ((k v))
298 | (string k '= v))
299 | it)))
300 | ""))
301 |
302 | (= fns* (table) fnids* nil timed-fnids* nil)
303 |
304 | ; count on huge (expt 64 10) size of fnid space to avoid clashes
305 |
306 | (def new-fnid ()
307 | (check (sym (rand-string 10)) ~fns* (new-fnid)))
308 |
309 | (def fnid (f)
310 | (atlet key (new-fnid)
311 | (= (fns* key) f)
312 | (push key fnids*)
313 | key))
314 |
315 | (def timed-fnid (lasts f)
316 | (atlet key (new-fnid)
317 | (= (fns* key) f)
318 | (push (list key (seconds) lasts) timed-fnids*)
319 | key))
320 |
321 | ; Within f, it will be bound to the fn's own fnid. Remember that this is
322 | ; so low-level that need to generate the newline to separate from the headers
323 | ; within the body of f.
324 |
325 | (mac afnid (f)
326 | `(atlet it (new-fnid)
327 | (= (fns* it) ,f)
328 | (push it fnids*)
329 | it))
330 |
331 | ;(defop test-afnid req
332 | ; (tag (a href (url-for (afnid (fn (req) (prn) (pr "my fnid is " it)))))
333 | ; (pr "click here")))
334 |
335 | ; To be more sophisticated, instead of killing fnids, could first
336 | ; replace them with fns that tell the server it's harvesting too
337 | ; aggressively if they start to get called. But the right thing to
338 | ; do is estimate what the max no of fnids can be and set the harvest
339 | ; limit there-- beyond that the only solution is to buy more memory.
340 |
341 | (def harvest-fnids ((o n 50000)) ; was 20000
342 | (when (len> fns* n)
343 | (pull (fn ((id created lasts))
344 | (when (> (since created) lasts)
345 | (wipe (fns* id))
346 | t))
347 | timed-fnids*)
348 | (atlet nharvest (trunc (/ n 10))
349 | (let (kill keep) (split (rev fnids*) nharvest)
350 | (= fnids* (rev keep))
351 | (each id kill
352 | (wipe (fns* id)))))))
353 |
354 | (= fnurl* "/x" rfnurl* "/r" rfnurl2* "/y" jfnurl* "/a")
355 |
356 | (= dead-msg* "\nUnknown or expired link.")
357 |
358 | (defop-raw x (str req)
359 | (w/stdout str
360 | (aif (fns* (sym (arg req "fnid")))
361 | (it req)
362 | (pr dead-msg*))))
363 |
364 | (defopr-raw y (str req)
365 | (aif (fns* (sym (arg req "fnid")))
366 | (w/stdout str (it req))
367 | "deadlink"))
368 |
369 | ; For asynchronous calls; discards the page. Would be better to tell
370 | ; the fn not to generate it.
371 |
372 | (defop-raw a (str req)
373 | (aif (fns* (sym (arg req "fnid")))
374 | (tostring (it req))))
375 |
376 | (defopr r req
377 | (aif (fns* (sym (arg req "fnid")))
378 | (it req)
379 | "deadlink"))
380 |
381 | (defop deadlink req
382 | (pr dead-msg*))
383 |
384 | (def url-for (fnid)
385 | (string fnurl* "?fnid=" fnid))
386 |
387 | (def flink (f)
388 | (string fnurl* "?fnid=" (fnid (fn (req) (prn) (f req)))))
389 |
390 | (def rflink (f)
391 | (string rfnurl* "?fnid=" (fnid f)))
392 |
393 | ; Since it's just an expr, gensym a parm for (ignored) args.
394 |
395 | (mac w/link (expr . body)
396 | `(tag (a href (flink (fn (,(uniq)) ,expr)))
397 | ,@body))
398 |
399 | (mac w/rlink (expr . body)
400 | `(tag (a href (rflink (fn (,(uniq)) ,expr)))
401 | ,@body))
402 |
403 | (mac onlink (text . body)
404 | `(w/link (do ,@body) (pr ,text)))
405 |
406 | (mac onrlink (text . body)
407 | `(w/rlink (do ,@body) (pr ,text)))
408 |
409 | ; bad to have both flink and linkf; rename flink something like fnid-link
410 |
411 | (mac linkf (text parms . body)
412 | `(tag (a href (flink (fn ,parms ,@body))) (pr ,text)))
413 |
414 | (mac rlinkf (text parms . body)
415 | `(tag (a href (rflink (fn ,parms ,@body))) (pr ,text)))
416 |
417 | ;(defop top req (linkf 'whoami? (req) (pr "I am " (get-user req))))
418 |
419 | ;(defop testf req (w/link (pr "ha ha ha") (pr "laugh")))
420 |
421 | (mac w/link-if (test expr . body)
422 | `(tag-if ,test (a href (flink (fn (,(uniq)) ,expr)))
423 | ,@body))
424 |
425 | (def fnid-field (id)
426 | (gentag input type 'hidden name 'fnid value id))
427 |
428 | ; f should be a fn of one arg, which will be http request args.
429 |
430 | (def fnform (f bodyfn (o redir))
431 | (tag (form method 'post action (if redir rfnurl2* fnurl*))
432 | (fnid-field (fnid f))
433 | (bodyfn)))
434 |
435 | ; Could also make a version that uses just an expr, and var capture.
436 | ; Is there a way to ensure user doesn't use "fnid" as a key?
437 |
438 | (mac aform (f . body)
439 | (w/uniq ga
440 | `(tag (form method 'post action fnurl*)
441 | (fnid-field (fnid (fn (,ga)
442 | (prn)
443 | (,f ,ga))))
444 | ,@body)))
445 |
446 | ;(defop test1 req
447 | ; (fnform (fn (req) (prn) (pr req))
448 | ; (fn () (single-input "" 'foo 20 "submit"))))
449 |
450 | ;(defop test2 req
451 | ; (aform (fn (req) (pr req))
452 | ; (single-input "" 'foo 20 "submit")))
453 |
454 | ; Like aform except creates a fnid that will last for lasts seconds
455 | ; (unless the server is restarted).
456 |
457 | (mac taform (lasts f . body)
458 | (w/uniq (gl gf gi ga)
459 | `(withs (,gl ,lasts
460 | ,gf (fn (,ga) (prn) (,f ,ga)))
461 | (tag (form method 'post action fnurl*)
462 | (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
463 | ,@body))))
464 |
465 | (mac arform (f . body)
466 | `(tag (form method 'post action rfnurl*)
467 | (fnid-field (fnid ,f))
468 | ,@body))
469 |
470 | ; overlong
471 |
472 | (mac tarform (lasts f . body)
473 | (w/uniq (gl gf)
474 | `(withs (,gl ,lasts ,gf ,f)
475 | (tag (form method 'post action rfnurl*)
476 | (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
477 | ,@body))))
478 |
479 | (mac aformh (f . body)
480 | `(tag (form method 'post action fnurl*)
481 | (fnid-field (fnid ,f))
482 | ,@body))
483 |
484 | (mac arformh (f . body)
485 | `(tag (form method 'post action rfnurl2*)
486 | (fnid-field (fnid ,f))
487 | ,@body))
488 |
489 | ; only unique per server invocation
490 |
491 | (= unique-ids* (table))
492 |
493 | (def unique-id ((o len 8))
494 | (let id (sym (rand-string (max 5 len)))
495 | (if (unique-ids* id)
496 | (unique-id)
497 | (= (unique-ids* id) id))))
498 |
499 | (def srvlog (type . args)
500 | (w/appendfile o (logfile-name type)
501 | (w/stdout o (atomic (apply prs (seconds) args) (prn)))))
502 |
503 | (def logfile-name (type)
504 | (string logdir* type "-" (memodate)))
505 |
506 | (with (lastasked nil lastval nil)
507 |
508 | (def memodate ()
509 | (let now (seconds)
510 | (if (or (no lastasked) (> (- now lastasked) 60))
511 | (= lastasked now lastval (datestring))
512 | lastval)))
513 |
514 | )
515 |
516 | (defop || req (pr "It's alive."))
517 |
518 | (defop topips req
519 | (when (admin (get-user req))
520 | (whitepage
521 | (sptab
522 | (each ip (let leaders nil
523 | (maptable (fn (ip n)
524 | (when (> n 100)
525 | (insort (compare > requests/ip*)
526 | ip
527 | leaders)))
528 | requests/ip*)
529 | leaders)
530 | (let n (requests/ip* ip)
531 | (row ip n (pr (num (* 100 (/ n requests*)) 1)))))))))
532 |
533 | (defop spurned req
534 | (when (admin (get-user req))
535 | (whitepage
536 | (sptab
537 | (map (fn ((ip n)) (row ip n))
538 | (sortable spurned*))))))
539 |
540 | ; eventually promote to general util
541 |
542 | (def sortable (ht (o f >))
543 | (let res nil
544 | (maptable (fn kv
545 | (insort (compare f cadr) kv res))
546 | ht)
547 | res))
548 |
549 |
550 | ; Background Threads
551 |
552 | (= bgthreads* (table) pending-bgthreads* nil)
553 |
554 | (def new-bgthread (id f sec)
555 | (aif (bgthreads* id) (break-thread it))
556 | (= (bgthreads* id) (new-thread (fn ()
557 | (while t
558 | (sleep sec)
559 | (f))))))
560 |
561 | ; should be a macro for this?
562 |
563 | (mac defbg (id sec . body)
564 | `(do (pull [caris _ ',id] pending-bgthreads*)
565 | (push (list ',id (fn () ,@body) ,sec)
566 | pending-bgthreads*)))
567 |
568 |
569 |
570 | ; Idea: make form fields that know their value type because of
571 | ; gensymed names, and so the receiving fn gets args that are not
572 | ; strings but parsed values.
573 |
574 |
--------------------------------------------------------------------------------
/arc3.1/static/arc.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/evanrmurphy/SweetScript/6b4ed26acc9c2df6fde028f57b19ecb4661943fb/arc3.1/static/arc.png
--------------------------------------------------------------------------------
/arc3.1/static/grayarrow.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/evanrmurphy/SweetScript/6b4ed26acc9c2df6fde028f57b19ecb4661943fb/arc3.1/static/grayarrow.gif
--------------------------------------------------------------------------------
/arc3.1/static/graydown.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/evanrmurphy/SweetScript/6b4ed26acc9c2df6fde028f57b19ecb4661943fb/arc3.1/static/graydown.gif
--------------------------------------------------------------------------------
/arc3.1/static/lis.py.txt:
--------------------------------------------------------------------------------
1 | ################ Lispy: Scheme Interpreter in Python
2 |
3 | ## (c) Peter Norvig, 2010; See http://norvig.com/lispy.html
4 |
5 | ################ Symbol, Procedure, Env classes
6 |
7 | from __future__ import division
8 |
9 | Symbol = str
10 |
11 | class Env(dict):
12 | "An environment: a dict of {'var':val} pairs, with an outer Env."
13 | def __init__(self, parms=(), args=(), outer=None):
14 | self.update(zip(parms,args))
15 | self.outer = outer
16 | def find(self, var):
17 | "Find the innermost Env where var appears."
18 | return self if var in self else self.outer.find(var)
19 |
20 | def add_globals(env):
21 | "Add some Scheme standard procedures to an environment."
22 | import math, operator as op
23 | env.update(vars(math)) # sin, sqrt, ...
24 | env.update(
25 | {'+':op.add, '-':op.sub, '*':op.mul, '/':op.div, 'not':op.not_,
26 | '>':op.gt, '<':op.lt, '>=':op.ge, '<=':op.le, '=':op.eq,
27 | 'equal?':op.eq, 'eq?':op.is_, 'length':len, 'cons':lambda x,y:[x]+y,
28 | 'car':lambda x:x[0],'cdr':lambda x:x[1:], 'append':op.add,
29 | 'list':lambda *x:list(x), 'list?': lambda x:isa(x,list),
30 | 'null?':lambda x:x==[], 'symbol?':lambda x: isa(x, Symbol)})
31 | return env
32 |
33 | global_env = add_globals(Env())
34 |
35 | isa = isinstance
36 |
37 | ################ eval
38 |
39 | def eval(x, env=global_env):
40 | "Evaluate an expression in an environment."
41 | if isa(x, Symbol): # variable reference
42 | return env.find(x)[x]
43 | elif not isa(x, list): # constant literal
44 | return x
45 | elif x[0] == 'quote': # (quote exp)
46 | (_, exp) = x
47 | return exp
48 | elif x[0] == 'if': # (if test conseq alt)
49 | (_, test, conseq, alt) = x
50 | return eval((conseq if eval(test, env) else alt), env)
51 | elif x[0] == 'set!': # (set! var exp)
52 | (_, var, exp) = x
53 | env.find(var)[var] = eval(exp, env)
54 | elif x[0] == 'define': # (define var exp)
55 | (_, var, exp) = x
56 | env[var] = eval(exp, env)
57 | elif x[0] == 'lambda': # (lambda (var*) exp)
58 | (_, vars, exp) = x
59 | return lambda *args: eval(exp, Env(vars, args, env))
60 | elif x[0] == 'begin': # (begin exp*)
61 | for exp in x[1:]:
62 | val = eval(exp, env)
63 | return val
64 | else: # (proc exp*)
65 | exps = [eval(exp, env) for exp in x]
66 | proc = exps.pop(0)
67 | return proc(*exps)
68 |
69 | ################ parse, read, and user interaction
70 |
71 | def read(s):
72 | "Read a Scheme expression from a string."
73 | return read_from(tokenize(s))
74 |
75 | parse = read
76 |
77 | def tokenize(s):
78 | "Convert a string into a list of tokens."
79 | return s.replace('(',' ( ').replace(')',' ) ').split()
80 |
81 | def read_from(tokens):
82 | "Read an expression from a sequence of tokens."
83 | if len(tokens) == 0:
84 | raise SyntaxError('unexpected EOF while reading')
85 | token = tokens.pop(0)
86 | if '(' == token:
87 | L = []
88 | while tokens[0] != ')':
89 | L.append(read_from(tokens))
90 | tokens.pop(0) # pop off ')'
91 | return L
92 | elif ')' == token:
93 | raise SyntaxError('unexpected )')
94 | else:
95 | return atom(token)
96 |
97 | def atom(token):
98 | "Numbers become numbers; every other token is a symbol."
99 | try: return int(token)
100 | except ValueError:
101 | try: return float(token)
102 | except ValueError:
103 | return Symbol(token)
104 |
105 | def to_string(exp):
106 | "Convert a Python object back into a Lisp-readable string."
107 | return '('+' '.join(map(to_string, exp))+')' if isa(exp, list) else str(exp)
108 |
109 | def repl(prompt='lis.py> '):
110 | "A prompt-read-eval-print loop."
111 | while True:
112 | val = eval(parse(raw_input(prompt)))
113 | if val is not None: print to_string(val)
114 |
--------------------------------------------------------------------------------
/arc3.1/static/robots.txt:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/evanrmurphy/SweetScript/6b4ed26acc9c2df6fde028f57b19ecb4661943fb/arc3.1/static/robots.txt
--------------------------------------------------------------------------------
/arc3.1/static/s.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/evanrmurphy/SweetScript/6b4ed26acc9c2df6fde028f57b19ecb4661943fb/arc3.1/static/s.gif
--------------------------------------------------------------------------------
/arc3.1/static/sweet-example.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 |
9 |
10 |
11 |
--------------------------------------------------------------------------------
/arc3.1/static/sweet-example.js:
--------------------------------------------------------------------------------
1 | (xs=[],render=(function(){return jQuery("#xs").empty(),_.each(xs,(function(x){return jQuery("#xs").append((("<"+"div"+">")+x+("")));}));}),jQuery((("<"+"input"+">")+(""))).change((function(){return xs.unshift(jQuery(this).val()),jQuery(this).val(""),render();})).appendTo("body"),jQuery((("<"+"div"+" "+("id"+"="+"\"xs\""+" ")+">")+(""))).appendTo("body"));
2 |
--------------------------------------------------------------------------------
/arc3.1/static/sweet.coffee:
--------------------------------------------------------------------------------
1 | # JavaScript port of http://norvig.com/lispy.html
2 |
3 | # Borrowed from http://javascript.crockford.com/remedial.html
4 | # to help distinguish arrays from other objects
5 | typeOf = (value) ->
6 | s = typeof value
7 | if s is 'object'
8 | if value
9 | if value instanceof Array
10 | s = 'array'
11 | else
12 | s = 'null'
13 | s
14 |
15 | isa = (x, y) ->
16 | typeOf(x) is y
17 |
18 | ################ Symbol, Procedure, Env classes
19 |
20 | Symbol = "string"
21 | list = "array"
22 |
23 | class Env
24 | constructor: (parms=[], args=[], outer=null) ->
25 | _(_.zip parms, args).each (keyVal) ->
26 | [key, val] = keyVal
27 | this[key] = val
28 | @outer = outer
29 | find: (Var) ->
30 | if Var of this then this else @outer?.find(Var)
31 |
32 | addGlobals = (env) ->
33 | _(env).extend
34 | '+': (x,y) -> x+y
35 | 'cons': (x,y) -> [x].concat(y)
36 | 'car': (xs) -> xs[0]
37 | 'cdr': (xs) -> xs[1..]
38 | env
39 |
40 | globalEnv = addGlobals(new Env)
41 |
42 | ################ Eval
43 |
44 | Eval = (x, env=globalEnv) ->
45 | console.log 'in Eval'
46 | console.log 'x is', x
47 | console.log 'env is', env
48 | if isa x, Symbol # variable reference
49 | console.log 'variable reference'
50 | env.find(x)[x]
51 | else if not isa x, list # constant literal
52 | console.log 'constant literal'
53 | x
54 | else if x[0] is 'quote' # (quote exp)
55 | [_, exp] = x
56 | exp
57 | else if x[0] is 'if' # (if test conseq alt)
58 | [_, test, conseq, alt] = x
59 | Eval (if Eval(test, env) then conseq else alt), env
60 | else if x[0] is '=' # (= var exp)
61 | console.log '(= var exp)'
62 | [_, Var, exp] = x
63 | if env.find(Var)
64 | env.find(Var)[Var] = Eval exp, env
65 | else
66 | env[Var] = Eval exp, env
67 | else if x[0] is 'fn' # (fn (var*) exp)
68 | [_, vars, exp] = x
69 | (args...) -> Eval exp, Env(vars, args, env) # should be new Env(vars...?
70 | else if x[0] is 'do' # (do exp*)
71 | val = Eval(exp, env) for exp in x[1..]
72 | val
73 | else # (proc exp*)
74 | console.log '(proc exp*)'
75 | exps = (Eval(exp, env) for exp in x)
76 | proc = exps.shift()
77 | console.log 'proc is', proc
78 | console.log 'exps is', exps
79 | proc exps...
80 |
81 | ################ parse, read and user interaction
82 |
83 | read = (s) ->
84 | readFrom tokenize(s)
85 |
86 | parse = read
87 |
88 | tokenize = (s) ->
89 | _(s.replace('(',' ( ').replace(')',' ) ').split(' ')).without('')
90 |
91 | readFrom = (tokens) ->
92 | if tokens.length == 0
93 | alert 'unexpected EOF while reading'
94 | token = tokens.shift()
95 | if '(' == token
96 | L = []
97 | while tokens[0] != ')'
98 | L.push(readFrom tokens)
99 | tokens.shift() # pop off ')'
100 | L
101 | else if ')' == token
102 | alert 'unexpected )'
103 | else
104 | atom token
105 |
106 | # Still needs to distinguish numbers from symbols
107 | atom = (token) ->
108 | if token.match /^\d+\.?$/
109 | parseInt token
110 | else if token.match /^\d*\.\d+$/
111 | parseFloat token
112 | else
113 | "#{token}"
114 |
115 | ToString = (exp) ->
116 | if isa exp, list
117 | '(' + (_(exp).map ToString).join(' ') + ')'
118 | else
119 | exp.toString()
120 |
121 | # Could use better UI than prompt + alert
122 | repl = (p='sweet> ') ->
123 | while input != '(quit)'
124 | input = (prompt p)
125 | val = Eval(parse input)
126 | alert(ToString val)
127 |
128 | window.repl = repl
129 | window.read = read
130 | window.parse = parse
131 | window.tokenize = tokenize
132 | window.ToString = ToString
133 | window.atom = atom
134 | window.Env = Env
135 | window.globalEnv = globalEnv
136 | window.Eval = Eval
137 |
138 | repl()
139 |
--------------------------------------------------------------------------------
/arc3.1/static/sweet.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 |
9 |
10 |
--------------------------------------------------------------------------------
/arc3.1/static/sweet.js:
--------------------------------------------------------------------------------
1 | (function() {
2 | var Env, Eval, Symbol, ToString, addGlobals, atom, globalEnv, isa, list, parse, read, readFrom, repl, tokenize, typeOf;
3 | var __slice = Array.prototype.slice;
4 | typeOf = function(value) {
5 | var s;
6 | s = typeof value;
7 | if (s === 'object') {
8 | if (value) {
9 | if (value instanceof Array) {
10 | s = 'array';
11 | } else {
12 | s = 'null';
13 | }
14 | }
15 | }
16 | return s;
17 | };
18 | isa = function(x, y) {
19 | return typeOf(x) === y;
20 | };
21 | Symbol = "string";
22 | list = "array";
23 | Env = function() {
24 | function Env(parms, args, outer) {
25 | if (parms == null) {
26 | parms = [];
27 | }
28 | if (args == null) {
29 | args = [];
30 | }
31 | if (outer == null) {
32 | outer = null;
33 | }
34 | _(_.zip(parms, args)).each(function(keyVal) {
35 | var key, val;
36 | key = keyVal[0], val = keyVal[1];
37 | return this[key] = val;
38 | });
39 | this.outer = outer;
40 | }
41 | Env.prototype.find = function(Var) {
42 | var _ref;
43 | if (Var in this) {
44 | return this;
45 | } else {
46 | return (_ref = this.outer) != null ? _ref.find(Var) : void 0;
47 | }
48 | };
49 | return Env;
50 | }();
51 | addGlobals = function(env) {
52 | _(env).extend({
53 | '+': function(x, y) {
54 | return x + y;
55 | },
56 | 'cons': function(x, y) {
57 | return [x].concat(y);
58 | },
59 | 'car': function(xs) {
60 | return xs[0];
61 | },
62 | 'cdr': function(xs) {
63 | return xs.slice(1);
64 | }
65 | });
66 | return env;
67 | };
68 | globalEnv = addGlobals(new Env);
69 | Eval = function(x, env) {
70 | var Var, alt, conseq, exp, exps, proc, test, val, vars, _, _i, _j, _len, _len2, _ref, _results;
71 | if (env == null) {
72 | env = globalEnv;
73 | }
74 | console.log('in Eval');
75 | console.log('x is', x);
76 | console.log('env is', env);
77 | if (isa(x, Symbol)) {
78 | console.log('variable reference');
79 | return env.find(x)[x];
80 | } else if (!isa(x, list)) {
81 | console.log('constant literal');
82 | return x;
83 | } else if (x[0] === 'quote') {
84 | _ = x[0], exp = x[1];
85 | return exp;
86 | } else if (x[0] === 'if') {
87 | _ = x[0], test = x[1], conseq = x[2], alt = x[3];
88 | return Eval((Eval(test, env) ? conseq : alt), env);
89 | } else if (x[0] === '=') {
90 | console.log('(= var exp)');
91 | _ = x[0], Var = x[1], exp = x[2];
92 | if (env.find(Var)) {
93 | return env.find(Var)[Var] = Eval(exp, env);
94 | } else {
95 | return env[Var] = Eval(exp, env);
96 | }
97 | } else if (x[0] === 'fn') {
98 | _ = x[0], vars = x[1], exp = x[2];
99 | return function() {
100 | var args;
101 | args = 1 <= arguments.length ? __slice.call(arguments, 0) : [];
102 | return Eval(exp, Env(vars, args, env));
103 | };
104 | } else if (x[0] === 'do') {
105 | _ref = x.slice(1);
106 | for (_i = 0, _len = _ref.length; _i < _len; _i++) {
107 | exp = _ref[_i];
108 | val = Eval(exp, env);
109 | }
110 | return val;
111 | } else {
112 | console.log('(proc exp*)');
113 | exps = (function() {
114 | _results = [];
115 | for (_j = 0, _len2 = x.length; _j < _len2; _j++) {
116 | exp = x[_j];
117 | _results.push(Eval(exp, env));
118 | }
119 | return _results;
120 | }());
121 | proc = exps.shift();
122 | console.log('proc is', proc);
123 | console.log('exps is', exps);
124 | return proc.apply(proc, exps);
125 | }
126 | };
127 | read = function(s) {
128 | return readFrom(tokenize(s));
129 | };
130 | parse = read;
131 | tokenize = function(s) {
132 | return _(s.replace('(', ' ( ').replace(')', ' ) ').split(' ')).without('');
133 | };
134 | readFrom = function(tokens) {
135 | var L, token;
136 | if (tokens.length === 0) {
137 | alert('unexpected EOF while reading');
138 | }
139 | token = tokens.shift();
140 | if ('(' === token) {
141 | L = [];
142 | while (tokens[0] !== ')') {
143 | L.push(readFrom(tokens));
144 | }
145 | tokens.shift();
146 | return L;
147 | } else if (')' === token) {
148 | return alert('unexpected )');
149 | } else {
150 | return atom(token);
151 | }
152 | };
153 | atom = function(token) {
154 | if (token.match(/^\d+\.?$/)) {
155 | return parseInt(token);
156 | } else if (token.match(/^\d*\.\d+$/)) {
157 | return parseFloat(token);
158 | } else {
159 | return "" + token;
160 | }
161 | };
162 | ToString = function(exp) {
163 | if (isa(exp, list)) {
164 | return '(' + (_(exp).map(ToString)).join(' ') + ')';
165 | } else {
166 | return exp.toString();
167 | }
168 | };
169 | repl = function(p) {
170 | var input, val, _results;
171 | if (p == null) {
172 | p = 'sweet> ';
173 | }
174 | _results = [];
175 | while (input !== '(quit)') {
176 | input = prompt(p);
177 | val = Eval(parse(input));
178 | _results.push(alert(ToString(val)));
179 | }
180 | return _results;
181 | };
182 | window.repl = repl;
183 | window.read = read;
184 | window.parse = parse;
185 | window.tokenize = tokenize;
186 | window.ToString = ToString;
187 | window.atom = atom;
188 | window.Env = Env;
189 | window.globalEnv = globalEnv;
190 | window.Eval = Eval;
191 | repl();
192 | }).call(this);
193 |
--------------------------------------------------------------------------------
/arc3.1/static/underscore.js:
--------------------------------------------------------------------------------
1 | // Underscore.js 1.1.3
2 | // (c) 2010 Jeremy Ashkenas, DocumentCloud Inc.
3 | // Underscore is freely distributable under the MIT license.
4 | // Portions of Underscore are inspired or borrowed from Prototype,
5 | // Oliver Steele's Functional, and John Resig's Micro-Templating.
6 | // For all details and documentation:
7 | // http://documentcloud.github.com/underscore
8 |
9 | (function() {
10 |
11 | // Baseline setup
12 | // --------------
13 |
14 | // Establish the root object, `window` in the browser, or `global` on the server.
15 | var root = this;
16 |
17 | // Save the previous value of the `_` variable.
18 | var previousUnderscore = root._;
19 |
20 | // Establish the object that gets returned to break out of a loop iteration.
21 | var breaker = {};
22 |
23 | // Save bytes in the minified (but not gzipped) version:
24 | var ArrayProto = Array.prototype, ObjProto = Object.prototype;
25 |
26 | // Create quick reference variables for speed access to core prototypes.
27 | var slice = ArrayProto.slice,
28 | unshift = ArrayProto.unshift,
29 | toString = ObjProto.toString,
30 | hasOwnProperty = ObjProto.hasOwnProperty;
31 |
32 | // All **ECMAScript 5** native function implementations that we hope to use
33 | // are declared here.
34 | var
35 | nativeForEach = ArrayProto.forEach,
36 | nativeMap = ArrayProto.map,
37 | nativeReduce = ArrayProto.reduce,
38 | nativeReduceRight = ArrayProto.reduceRight,
39 | nativeFilter = ArrayProto.filter,
40 | nativeEvery = ArrayProto.every,
41 | nativeSome = ArrayProto.some,
42 | nativeIndexOf = ArrayProto.indexOf,
43 | nativeLastIndexOf = ArrayProto.lastIndexOf,
44 | nativeIsArray = Array.isArray,
45 | nativeKeys = Object.keys;
46 |
47 | // Create a safe reference to the Underscore object for use below.
48 | var _ = function(obj) { return new wrapper(obj); };
49 |
50 | // Export the Underscore object for **CommonJS**, with backwards-compatibility
51 | // for the old `require()` API. If we're not in CommonJS, add `_` to the
52 | // global object.
53 | if (typeof module !== 'undefined' && module.exports) {
54 | module.exports = _;
55 | _._ = _;
56 | } else {
57 | root._ = _;
58 | }
59 |
60 | // Current version.
61 | _.VERSION = '1.1.3';
62 |
63 | // Collection Functions
64 | // --------------------
65 |
66 | // The cornerstone, an `each` implementation, aka `forEach`.
67 | // Handles objects implementing `forEach`, arrays, and raw objects.
68 | // Delegates to **ECMAScript 5**'s native `forEach` if available.
69 | var each = _.each = _.forEach = function(obj, iterator, context) {
70 | var value;
71 | if (nativeForEach && obj.forEach === nativeForEach) {
72 | obj.forEach(iterator, context);
73 | } else if (_.isNumber(obj.length)) {
74 | for (var i = 0, l = obj.length; i < l; i++) {
75 | if (iterator.call(context, obj[i], i, obj) === breaker) return;
76 | }
77 | } else {
78 | for (var key in obj) {
79 | if (hasOwnProperty.call(obj, key)) {
80 | if (iterator.call(context, obj[key], key, obj) === breaker) return;
81 | }
82 | }
83 | }
84 | };
85 |
86 | // Return the results of applying the iterator to each element.
87 | // Delegates to **ECMAScript 5**'s native `map` if available.
88 | _.map = function(obj, iterator, context) {
89 | if (nativeMap && obj.map === nativeMap) return obj.map(iterator, context);
90 | var results = [];
91 | each(obj, function(value, index, list) {
92 | results[results.length] = iterator.call(context, value, index, list);
93 | });
94 | return results;
95 | };
96 |
97 | // **Reduce** builds up a single result from a list of values, aka `inject`,
98 | // or `foldl`. Delegates to **ECMAScript 5**'s native `reduce` if available.
99 | _.reduce = _.foldl = _.inject = function(obj, iterator, memo, context) {
100 | var initial = memo !== void 0;
101 | if (nativeReduce && obj.reduce === nativeReduce) {
102 | if (context) iterator = _.bind(iterator, context);
103 | return initial ? obj.reduce(iterator, memo) : obj.reduce(iterator);
104 | }
105 | each(obj, function(value, index, list) {
106 | if (!initial && index === 0) {
107 | memo = value;
108 | } else {
109 | memo = iterator.call(context, memo, value, index, list);
110 | }
111 | });
112 | return memo;
113 | };
114 |
115 | // The right-associative version of reduce, also known as `foldr`.
116 | // Delegates to **ECMAScript 5**'s native `reduceRight` if available.
117 | _.reduceRight = _.foldr = function(obj, iterator, memo, context) {
118 | if (nativeReduceRight && obj.reduceRight === nativeReduceRight) {
119 | if (context) iterator = _.bind(iterator, context);
120 | return memo !== void 0 ? obj.reduceRight(iterator, memo) : obj.reduceRight(iterator);
121 | }
122 | var reversed = (_.isArray(obj) ? obj.slice() : _.toArray(obj)).reverse();
123 | return _.reduce(reversed, iterator, memo, context);
124 | };
125 |
126 | // Return the first value which passes a truth test. Aliased as `detect`.
127 | _.find = _.detect = function(obj, iterator, context) {
128 | var result;
129 | any(obj, function(value, index, list) {
130 | if (iterator.call(context, value, index, list)) {
131 | result = value;
132 | return true;
133 | }
134 | });
135 | return result;
136 | };
137 |
138 | // Return all the elements that pass a truth test.
139 | // Delegates to **ECMAScript 5**'s native `filter` if available.
140 | // Aliased as `select`.
141 | _.filter = _.select = function(obj, iterator, context) {
142 | if (nativeFilter && obj.filter === nativeFilter) return obj.filter(iterator, context);
143 | var results = [];
144 | each(obj, function(value, index, list) {
145 | if (iterator.call(context, value, index, list)) results[results.length] = value;
146 | });
147 | return results;
148 | };
149 |
150 | // Return all the elements for which a truth test fails.
151 | _.reject = function(obj, iterator, context) {
152 | var results = [];
153 | each(obj, function(value, index, list) {
154 | if (!iterator.call(context, value, index, list)) results[results.length] = value;
155 | });
156 | return results;
157 | };
158 |
159 | // Determine whether all of the elements match a truth test.
160 | // Delegates to **ECMAScript 5**'s native `every` if available.
161 | // Aliased as `all`.
162 | _.every = _.all = function(obj, iterator, context) {
163 | iterator = iterator || _.identity;
164 | if (nativeEvery && obj.every === nativeEvery) return obj.every(iterator, context);
165 | var result = true;
166 | each(obj, function(value, index, list) {
167 | if (!(result = result && iterator.call(context, value, index, list))) return breaker;
168 | });
169 | return result;
170 | };
171 |
172 | // Determine if at least one element in the object matches a truth test.
173 | // Delegates to **ECMAScript 5**'s native `some` if available.
174 | // Aliased as `any`.
175 | var any = _.some = _.any = function(obj, iterator, context) {
176 | iterator = iterator || _.identity;
177 | if (nativeSome && obj.some === nativeSome) return obj.some(iterator, context);
178 | var result = false;
179 | each(obj, function(value, index, list) {
180 | if (result = iterator.call(context, value, index, list)) return breaker;
181 | });
182 | return result;
183 | };
184 |
185 | // Determine if a given value is included in the array or object using `===`.
186 | // Aliased as `contains`.
187 | _.include = _.contains = function(obj, target) {
188 | if (nativeIndexOf && obj.indexOf === nativeIndexOf) return obj.indexOf(target) != -1;
189 | var found = false;
190 | any(obj, function(value) {
191 | if (found = value === target) return true;
192 | });
193 | return found;
194 | };
195 |
196 | // Invoke a method (with arguments) on every item in a collection.
197 | _.invoke = function(obj, method) {
198 | var args = slice.call(arguments, 2);
199 | return _.map(obj, function(value) {
200 | return (method ? value[method] : value).apply(value, args);
201 | });
202 | };
203 |
204 | // Convenience version of a common use case of `map`: fetching a property.
205 | _.pluck = function(obj, key) {
206 | return _.map(obj, function(value){ return value[key]; });
207 | };
208 |
209 | // Return the maximum element or (element-based computation).
210 | _.max = function(obj, iterator, context) {
211 | if (!iterator && _.isArray(obj)) return Math.max.apply(Math, obj);
212 | var result = {computed : -Infinity};
213 | each(obj, function(value, index, list) {
214 | var computed = iterator ? iterator.call(context, value, index, list) : value;
215 | computed >= result.computed && (result = {value : value, computed : computed});
216 | });
217 | return result.value;
218 | };
219 |
220 | // Return the minimum element (or element-based computation).
221 | _.min = function(obj, iterator, context) {
222 | if (!iterator && _.isArray(obj)) return Math.min.apply(Math, obj);
223 | var result = {computed : Infinity};
224 | each(obj, function(value, index, list) {
225 | var computed = iterator ? iterator.call(context, value, index, list) : value;
226 | computed < result.computed && (result = {value : value, computed : computed});
227 | });
228 | return result.value;
229 | };
230 |
231 | // Sort the object's values by a criterion produced by an iterator.
232 | _.sortBy = function(obj, iterator, context) {
233 | return _.pluck(_.map(obj, function(value, index, list) {
234 | return {
235 | value : value,
236 | criteria : iterator.call(context, value, index, list)
237 | };
238 | }).sort(function(left, right) {
239 | var a = left.criteria, b = right.criteria;
240 | return a < b ? -1 : a > b ? 1 : 0;
241 | }), 'value');
242 | };
243 |
244 | // Use a comparator function to figure out at what index an object should
245 | // be inserted so as to maintain order. Uses binary search.
246 | _.sortedIndex = function(array, obj, iterator) {
247 | iterator = iterator || _.identity;
248 | var low = 0, high = array.length;
249 | while (low < high) {
250 | var mid = (low + high) >> 1;
251 | iterator(array[mid]) < iterator(obj) ? low = mid + 1 : high = mid;
252 | }
253 | return low;
254 | };
255 |
256 | // Safely convert anything iterable into a real, live array.
257 | _.toArray = function(iterable) {
258 | if (!iterable) return [];
259 | if (iterable.toArray) return iterable.toArray();
260 | if (_.isArray(iterable)) return iterable;
261 | if (_.isArguments(iterable)) return slice.call(iterable);
262 | return _.values(iterable);
263 | };
264 |
265 | // Return the number of elements in an object.
266 | _.size = function(obj) {
267 | return _.toArray(obj).length;
268 | };
269 |
270 | // Array Functions
271 | // ---------------
272 |
273 | // Get the first element of an array. Passing **n** will return the first N
274 | // values in the array. Aliased as `head`. The **guard** check allows it to work
275 | // with `_.map`.
276 | _.first = _.head = function(array, n, guard) {
277 | return n && !guard ? slice.call(array, 0, n) : array[0];
278 | };
279 |
280 | // Returns everything but the first entry of the array. Aliased as `tail`.
281 | // Especially useful on the arguments object. Passing an **index** will return
282 | // the rest of the values in the array from that index onward. The **guard**
283 | // check allows it to work with `_.map`.
284 | _.rest = _.tail = function(array, index, guard) {
285 | return slice.call(array, _.isUndefined(index) || guard ? 1 : index);
286 | };
287 |
288 | // Get the last element of an array.
289 | _.last = function(array) {
290 | return array[array.length - 1];
291 | };
292 |
293 | // Trim out all falsy values from an array.
294 | _.compact = function(array) {
295 | return _.filter(array, function(value){ return !!value; });
296 | };
297 |
298 | // Return a completely flattened version of an array.
299 | _.flatten = function(array) {
300 | return _.reduce(array, function(memo, value) {
301 | if (_.isArray(value)) return memo.concat(_.flatten(value));
302 | memo[memo.length] = value;
303 | return memo;
304 | }, []);
305 | };
306 |
307 | // Return a version of the array that does not contain the specified value(s).
308 | _.without = function(array) {
309 | var values = slice.call(arguments, 1);
310 | return _.filter(array, function(value){ return !_.include(values, value); });
311 | };
312 |
313 | // Produce a duplicate-free version of the array. If the array has already
314 | // been sorted, you have the option of using a faster algorithm.
315 | // Aliased as `unique`.
316 | _.uniq = _.unique = function(array, isSorted) {
317 | return _.reduce(array, function(memo, el, i) {
318 | if (0 == i || (isSorted === true ? _.last(memo) != el : !_.include(memo, el))) memo[memo.length] = el;
319 | return memo;
320 | }, []);
321 | };
322 |
323 | // Produce an array that contains every item shared between all the
324 | // passed-in arrays.
325 | _.intersect = function(array) {
326 | var rest = slice.call(arguments, 1);
327 | return _.filter(_.uniq(array), function(item) {
328 | return _.every(rest, function(other) {
329 | return _.indexOf(other, item) >= 0;
330 | });
331 | });
332 | };
333 |
334 | // Zip together multiple lists into a single array -- elements that share
335 | // an index go together.
336 | _.zip = function() {
337 | var args = slice.call(arguments);
338 | var length = _.max(_.pluck(args, 'length'));
339 | var results = new Array(length);
340 | for (var i = 0; i < length; i++) results[i] = _.pluck(args, "" + i);
341 | return results;
342 | };
343 |
344 | // If the browser doesn't supply us with indexOf (I'm looking at you, **MSIE**),
345 | // we need this function. Return the position of the first occurrence of an
346 | // item in an array, or -1 if the item is not included in the array.
347 | // Delegates to **ECMAScript 5**'s native `indexOf` if available.
348 | _.indexOf = function(array, item) {
349 | if (nativeIndexOf && array.indexOf === nativeIndexOf) return array.indexOf(item);
350 | for (var i = 0, l = array.length; i < l; i++) if (array[i] === item) return i;
351 | return -1;
352 | };
353 |
354 |
355 | // Delegates to **ECMAScript 5**'s native `lastIndexOf` if available.
356 | _.lastIndexOf = function(array, item) {
357 | if (nativeLastIndexOf && array.lastIndexOf === nativeLastIndexOf) return array.lastIndexOf(item);
358 | var i = array.length;
359 | while (i--) if (array[i] === item) return i;
360 | return -1;
361 | };
362 |
363 | // Generate an integer Array containing an arithmetic progression. A port of
364 | // the native Python `range()` function. See
365 | // [the Python documentation](http://docs.python.org/library/functions.html#range).
366 | _.range = function(start, stop, step) {
367 | var args = slice.call(arguments),
368 | solo = args.length <= 1,
369 | start = solo ? 0 : args[0],
370 | stop = solo ? args[0] : args[1],
371 | step = args[2] || 1,
372 | len = Math.max(Math.ceil((stop - start) / step), 0),
373 | idx = 0,
374 | range = new Array(len);
375 | while (idx < len) {
376 | range[idx++] = start;
377 | start += step;
378 | }
379 | return range;
380 | };
381 |
382 | // Function (ahem) Functions
383 | // ------------------
384 |
385 | // Create a function bound to a given object (assigning `this`, and arguments,
386 | // optionally). Binding with arguments is also known as `curry`.
387 | _.bind = function(func, obj) {
388 | var args = slice.call(arguments, 2);
389 | return function() {
390 | return func.apply(obj || {}, args.concat(slice.call(arguments)));
391 | };
392 | };
393 |
394 | // Bind all of an object's methods to that object. Useful for ensuring that
395 | // all callbacks defined on an object belong to it.
396 | _.bindAll = function(obj) {
397 | var funcs = slice.call(arguments, 1);
398 | if (funcs.length == 0) funcs = _.functions(obj);
399 | each(funcs, function(f) { obj[f] = _.bind(obj[f], obj); });
400 | return obj;
401 | };
402 |
403 | // Memoize an expensive function by storing its results.
404 | _.memoize = function(func, hasher) {
405 | var memo = {};
406 | hasher = hasher || _.identity;
407 | return function() {
408 | var key = hasher.apply(this, arguments);
409 | return key in memo ? memo[key] : (memo[key] = func.apply(this, arguments));
410 | };
411 | };
412 |
413 | // Delays a function for the given number of milliseconds, and then calls
414 | // it with the arguments supplied.
415 | _.delay = function(func, wait) {
416 | var args = slice.call(arguments, 2);
417 | return setTimeout(function(){ return func.apply(func, args); }, wait);
418 | };
419 |
420 | // Defers a function, scheduling it to run after the current call stack has
421 | // cleared.
422 | _.defer = function(func) {
423 | return _.delay.apply(_, [func, 1].concat(slice.call(arguments, 1)));
424 | };
425 |
426 | // Internal function used to implement `_.throttle` and `_.debounce`.
427 | var limit = function(func, wait, debounce) {
428 | var timeout;
429 | return function() {
430 | var context = this, args = arguments;
431 | var throttler = function() {
432 | timeout = null;
433 | func.apply(context, args);
434 | };
435 | if (debounce) clearTimeout(timeout);
436 | if (debounce || !timeout) timeout = setTimeout(throttler, wait);
437 | };
438 | };
439 |
440 | // Returns a function, that, when invoked, will only be triggered at most once
441 | // during a given window of time.
442 | _.throttle = function(func, wait) {
443 | return limit(func, wait, false);
444 | };
445 |
446 | // Returns a function, that, as long as it continues to be invoked, will not
447 | // be triggered. The function will be called after it stops being called for
448 | // N milliseconds.
449 | _.debounce = function(func, wait) {
450 | return limit(func, wait, true);
451 | };
452 |
453 | // Returns the first function passed as an argument to the second,
454 | // allowing you to adjust arguments, run code before and after, and
455 | // conditionally execute the original function.
456 | _.wrap = function(func, wrapper) {
457 | return function() {
458 | var args = [func].concat(slice.call(arguments));
459 | return wrapper.apply(wrapper, args);
460 | };
461 | };
462 |
463 | // Returns a function that is the composition of a list of functions, each
464 | // consuming the return value of the function that follows.
465 | _.compose = function() {
466 | var funcs = slice.call(arguments);
467 | return function() {
468 | var args = slice.call(arguments);
469 | for (var i=funcs.length-1; i >= 0; i--) {
470 | args = [funcs[i].apply(this, args)];
471 | }
472 | return args[0];
473 | };
474 | };
475 |
476 | // Object Functions
477 | // ----------------
478 |
479 | // Retrieve the names of an object's properties.
480 | // Delegates to **ECMAScript 5**'s native `Object.keys`
481 | _.keys = nativeKeys || function(obj) {
482 | if (_.isArray(obj)) return _.range(0, obj.length);
483 | var keys = [];
484 | for (var key in obj) if (hasOwnProperty.call(obj, key)) keys[keys.length] = key;
485 | return keys;
486 | };
487 |
488 | // Retrieve the values of an object's properties.
489 | _.values = function(obj) {
490 | return _.map(obj, _.identity);
491 | };
492 |
493 | // Return a sorted list of the function names available on the object.
494 | // Aliased as `methods`
495 | _.functions = _.methods = function(obj) {
496 | return _.filter(_.keys(obj), function(key){ return _.isFunction(obj[key]); }).sort();
497 | };
498 |
499 | // Extend a given object with all the properties in passed-in object(s).
500 | _.extend = function(obj) {
501 | each(slice.call(arguments, 1), function(source) {
502 | for (var prop in source) obj[prop] = source[prop];
503 | });
504 | return obj;
505 | };
506 |
507 | // Create a (shallow-cloned) duplicate of an object.
508 | _.clone = function(obj) {
509 | return _.isArray(obj) ? obj.slice() : _.extend({}, obj);
510 | };
511 |
512 | // Invokes interceptor with the obj, and then returns obj.
513 | // The primary purpose of this method is to "tap into" a method chain, in
514 | // order to perform operations on intermediate results within the chain.
515 | _.tap = function(obj, interceptor) {
516 | interceptor(obj);
517 | return obj;
518 | };
519 |
520 | // Perform a deep comparison to check if two objects are equal.
521 | _.isEqual = function(a, b) {
522 | // Check object identity.
523 | if (a === b) return true;
524 | // Different types?
525 | var atype = typeof(a), btype = typeof(b);
526 | if (atype != btype) return false;
527 | // Basic equality test (watch out for coercions).
528 | if (a == b) return true;
529 | // One is falsy and the other truthy.
530 | if ((!a && b) || (a && !b)) return false;
531 | // One of them implements an isEqual()?
532 | if (a.isEqual) return a.isEqual(b);
533 | // Check dates' integer values.
534 | if (_.isDate(a) && _.isDate(b)) return a.getTime() === b.getTime();
535 | // Both are NaN?
536 | if (_.isNaN(a) && _.isNaN(b)) return false;
537 | // Compare regular expressions.
538 | if (_.isRegExp(a) && _.isRegExp(b))
539 | return a.source === b.source &&
540 | a.global === b.global &&
541 | a.ignoreCase === b.ignoreCase &&
542 | a.multiline === b.multiline;
543 | // If a is not an object by this point, we can't handle it.
544 | if (atype !== 'object') return false;
545 | // Check for different array lengths before comparing contents.
546 | if (a.length && (a.length !== b.length)) return false;
547 | // Nothing else worked, deep compare the contents.
548 | var aKeys = _.keys(a), bKeys = _.keys(b);
549 | // Different object sizes?
550 | if (aKeys.length != bKeys.length) return false;
551 | // Recursive comparison of contents.
552 | for (var key in a) if (!(key in b) || !_.isEqual(a[key], b[key])) return false;
553 | return true;
554 | };
555 |
556 | // Is a given array or object empty?
557 | _.isEmpty = function(obj) {
558 | if (_.isArray(obj) || _.isString(obj)) return obj.length === 0;
559 | for (var key in obj) if (hasOwnProperty.call(obj, key)) return false;
560 | return true;
561 | };
562 |
563 | // Is a given value a DOM element?
564 | _.isElement = function(obj) {
565 | return !!(obj && obj.nodeType == 1);
566 | };
567 |
568 | // Is a given value an array?
569 | // Delegates to ECMA5's native Array.isArray
570 | _.isArray = nativeIsArray || function(obj) {
571 | return !!(obj && obj.concat && obj.unshift && !obj.callee);
572 | };
573 |
574 | // Is a given variable an arguments object?
575 | _.isArguments = function(obj) {
576 | return !!(obj && obj.callee);
577 | };
578 |
579 | // Is a given value a function?
580 | _.isFunction = function(obj) {
581 | return !!(obj && obj.constructor && obj.call && obj.apply);
582 | };
583 |
584 | // Is a given value a string?
585 | _.isString = function(obj) {
586 | return !!(obj === '' || (obj && obj.charCodeAt && obj.substr));
587 | };
588 |
589 | // Is a given value a number?
590 | _.isNumber = function(obj) {
591 | return !!(obj === 0 || (obj && obj.toExponential && obj.toFixed));
592 | };
593 |
594 | // Is the given value NaN -- this one is interesting. NaN != NaN, and
595 | // isNaN(undefined) == true, so we make sure it's a number first.
596 | _.isNaN = function(obj) {
597 | return toString.call(obj) === '[object Number]' && isNaN(obj);
598 | };
599 |
600 | // Is a given value a boolean?
601 | _.isBoolean = function(obj) {
602 | return obj === true || obj === false;
603 | };
604 |
605 | // Is a given value a date?
606 | _.isDate = function(obj) {
607 | return !!(obj && obj.getTimezoneOffset && obj.setUTCFullYear);
608 | };
609 |
610 | // Is the given value a regular expression?
611 | _.isRegExp = function(obj) {
612 | return !!(obj && obj.test && obj.exec && (obj.ignoreCase || obj.ignoreCase === false));
613 | };
614 |
615 | // Is a given value equal to null?
616 | _.isNull = function(obj) {
617 | return obj === null;
618 | };
619 |
620 | // Is a given variable undefined?
621 | _.isUndefined = function(obj) {
622 | return obj === void 0;
623 | };
624 |
625 | // Utility Functions
626 | // -----------------
627 |
628 | // Run Underscore.js in *noConflict* mode, returning the `_` variable to its
629 | // previous owner. Returns a reference to the Underscore object.
630 | _.noConflict = function() {
631 | root._ = previousUnderscore;
632 | return this;
633 | };
634 |
635 | // Keep the identity function around for default iterators.
636 | _.identity = function(value) {
637 | return value;
638 | };
639 |
640 | // Run a function **n** times.
641 | _.times = function (n, iterator, context) {
642 | for (var i = 0; i < n; i++) iterator.call(context, i);
643 | };
644 |
645 | // Add your own custom functions to the Underscore object, ensuring that
646 | // they're correctly added to the OOP wrapper as well.
647 | _.mixin = function(obj) {
648 | each(_.functions(obj), function(name){
649 | addToWrapper(name, _[name] = obj[name]);
650 | });
651 | };
652 |
653 | // Generate a unique integer id (unique within the entire client session).
654 | // Useful for temporary DOM ids.
655 | var idCounter = 0;
656 | _.uniqueId = function(prefix) {
657 | var id = idCounter++;
658 | return prefix ? prefix + id : id;
659 | };
660 |
661 | // By default, Underscore uses ERB-style template delimiters, change the
662 | // following template settings to use alternative delimiters.
663 | _.templateSettings = {
664 | evaluate : /<%([\s\S]+?)%>/g,
665 | interpolate : /<%=([\s\S]+?)%>/g
666 | };
667 |
668 | // JavaScript micro-templating, similar to John Resig's implementation.
669 | // Underscore templating handles arbitrary delimiters, preserves whitespace,
670 | // and correctly escapes quotes within interpolated code.
671 | _.template = function(str, data) {
672 | var c = _.templateSettings;
673 | var tmpl = 'var __p=[],print=function(){__p.push.apply(__p,arguments);};' +
674 | 'with(obj||{}){__p.push(\'' +
675 | str.replace(/\\/g, '\\\\')
676 | .replace(/'/g, "\\'")
677 | .replace(c.interpolate, function(match, code) {
678 | return "'," + code.replace(/\\'/g, "'") + ",'";
679 | })
680 | .replace(c.evaluate || null, function(match, code) {
681 | return "');" + code.replace(/\\'/g, "'")
682 | .replace(/[\r\n\t]/g, ' ') + "__p.push('";
683 | })
684 | .replace(/\r/g, '\\r')
685 | .replace(/\n/g, '\\n')
686 | .replace(/\t/g, '\\t')
687 | + "');}return __p.join('');";
688 | var func = new Function('obj', tmpl);
689 | return data ? func(data) : func;
690 | };
691 |
692 | // The OOP Wrapper
693 | // ---------------
694 |
695 | // If Underscore is called as a function, it returns a wrapped object that
696 | // can be used OO-style. This wrapper holds altered versions of all the
697 | // underscore functions. Wrapped objects may be chained.
698 | var wrapper = function(obj) { this._wrapped = obj; };
699 |
700 | // Expose `wrapper.prototype` as `_.prototype`
701 | _.prototype = wrapper.prototype;
702 |
703 | // Helper function to continue chaining intermediate results.
704 | var result = function(obj, chain) {
705 | return chain ? _(obj).chain() : obj;
706 | };
707 |
708 | // A method to easily add functions to the OOP wrapper.
709 | var addToWrapper = function(name, func) {
710 | wrapper.prototype[name] = function() {
711 | var args = slice.call(arguments);
712 | unshift.call(args, this._wrapped);
713 | return result(func.apply(_, args), this._chain);
714 | };
715 | };
716 |
717 | // Add all of the Underscore functions to the wrapper object.
718 | _.mixin(_);
719 |
720 | // Add all mutator Array functions to the wrapper.
721 | each(['pop', 'push', 'reverse', 'shift', 'sort', 'splice', 'unshift'], function(name) {
722 | var method = ArrayProto[name];
723 | wrapper.prototype[name] = function() {
724 | method.apply(this._wrapped, arguments);
725 | return result(this._wrapped, this._chain);
726 | };
727 | });
728 |
729 | // Add all accessor Array functions to the wrapper.
730 | each(['concat', 'join', 'slice'], function(name) {
731 | var method = ArrayProto[name];
732 | wrapper.prototype[name] = function() {
733 | return result(method.apply(this._wrapped, arguments), this._chain);
734 | };
735 | });
736 |
737 | // Start chaining a wrapped Underscore object.
738 | wrapper.prototype.chain = function() {
739 | this._chain = true;
740 | return this;
741 | };
742 |
743 | // Extracts the result from a wrapped and chained object.
744 | wrapper.prototype.value = function() {
745 | return this._wrapped;
746 | };
747 |
748 | })();
749 |
--------------------------------------------------------------------------------
/arc3.1/strings.arc:
--------------------------------------------------------------------------------
1 | ; Matching. Spun off 29 Jul 06.
2 |
3 | ; arc> (tostring (writec (coerce 133 'char)))
4 | ;
5 | ;> (define ss (open-output-string))
6 | ;> (write-char (integer->char 133) ss)
7 | ;> (get-output-string ss)
8 | ;"\u0085"
9 |
10 | (def tokens (s (o sep whitec))
11 | (let test (testify sep)
12 | (let rec (afn (cs toks tok)
13 | (if (no cs) (consif tok toks)
14 | (test (car cs)) (self (cdr cs) (consif tok toks) nil)
15 | (self (cdr cs) toks (cons (car cs) tok))))
16 | (rev (map [coerce _ 'string]
17 | (map rev (rec (coerce s 'cons) nil nil)))))))
18 |
19 | ; names of cut, split, halve not optimal
20 |
21 | (def halve (s (o sep whitec))
22 | (let test (testify sep)
23 | (let rec (afn (cs tok)
24 | (if (no cs) (list (rev tok))
25 | (test (car cs)) (list cs (rev tok))
26 | (self (cdr cs) (cons (car cs) tok))))
27 | (rev (map [coerce _ 'string]
28 | (rec (coerce s 'cons) nil))))))
29 |
30 | ; maybe promote to arc.arc, but if so include a list clause
31 |
32 | (def positions (test seq)
33 | (accum a
34 | (let f (testify test)
35 | (forlen i seq
36 | (if (f (seq i)) (a i))))))
37 |
38 | (def lines (s)
39 | (accum a
40 | ((afn ((p . ps))
41 | (if ps
42 | (do (a (rem #\return (cut s (+ p 1) (car ps))))
43 | (self ps))
44 | (a (cut s (+ p 1)))))
45 | (cons -1 (positions #\newline s)))))
46 |
47 | (def slices (s test)
48 | (accum a
49 | ((afn ((p . ps))
50 | (if ps
51 | (do (a (cut s (+ p 1) (car ps)))
52 | (self ps))
53 | (a (cut s (+ p 1)))))
54 | (cons -1 (positions test s)))))
55 |
56 | ; > (require (lib "uri-codec.ss" "net"))
57 | ;> (form-urlencoded-decode "x%ce%bbx")
58 | ;"xλx"
59 |
60 | ; first byte: 0-7F, 1 char; c2-df 2; e0-ef 3, f0-f4 4.
61 |
62 | ; Fixed for utf8 by pc.
63 |
64 | (def urldecode (s)
65 | (tostring
66 | (forlen i s
67 | (caselet c (s i)
68 | #\+ (writec #\space)
69 | #\% (do (when (> (- (len s) i) 2)
70 | (writeb (int (cut s (+ i 1) (+ i 3)) 16)))
71 | (++ i 2))
72 | (writec c)))))
73 |
74 | (def urlencode (s)
75 | (tostring
76 | (each c s
77 | (writec #\%)
78 | (let i (int c)
79 | (if (< i 16) (writec #\0))
80 | (pr (coerce i 'string 16))))))
81 |
82 | (mac litmatch (pat string (o start 0))
83 | (w/uniq (gstring gstart)
84 | `(with (,gstring ,string ,gstart ,start)
85 | (unless (> (+ ,gstart ,(len pat)) (len ,gstring))
86 | (and ,@(let acc nil
87 | (forlen i pat
88 | (push `(is ,(pat i) (,gstring (+ ,gstart ,i)))
89 | acc))
90 | (rev acc)))))))
91 |
92 | ; litmatch would be cleaner if map worked for string and integer args:
93 |
94 | ; ,@(map (fn (n c)
95 | ; `(is ,c (,gstring (+ ,gstart ,n))))
96 | ; (len pat)
97 | ; pat)
98 |
99 | (mac endmatch (pat string)
100 | (w/uniq (gstring glen)
101 | `(withs (,gstring ,string ,glen (len ,gstring))
102 | (unless (> ,(len pat) (len ,gstring))
103 | (and ,@(let acc nil
104 | (forlen i pat
105 | (push `(is ,(pat (- (len pat) 1 i))
106 | (,gstring (- ,glen 1 ,i)))
107 | acc))
108 | (rev acc)))))))
109 |
110 | (def posmatch (pat seq (o start 0))
111 | (catch
112 | (if (isa pat 'fn)
113 | (for i start (- (len seq) 1)
114 | (when (pat (seq i)) (throw i)))
115 | (for i start (- (len seq) (len pat))
116 | (when (headmatch pat seq i) (throw i))))
117 | nil))
118 |
119 | (def headmatch (pat seq (o start 0))
120 | (let p (len pat)
121 | ((afn (i)
122 | (or (is i p)
123 | (and (is (pat i) (seq (+ i start)))
124 | (self (+ i 1)))))
125 | 0)))
126 |
127 | (def begins (seq pat (o start 0))
128 | (unless (len> pat (- (len seq) start))
129 | (headmatch pat seq start)))
130 |
131 | (def subst (new old seq)
132 | (let boundary (+ (- (len seq) (len old)) 1)
133 | (tostring
134 | (forlen i seq
135 | (if (and (< i boundary) (headmatch old seq i))
136 | (do (++ i (- (len old) 1))
137 | (pr new))
138 | (pr (seq i)))))))
139 |
140 | (def multisubst (pairs seq)
141 | (tostring
142 | (forlen i seq
143 | (iflet (old new) (find [begins seq (car _) i] pairs)
144 | (do (++ i (- (len old) 1))
145 | (pr new))
146 | (pr (seq i))))))
147 |
148 | ; not a good name
149 |
150 | (def findsubseq (pat seq (o start 0))
151 | (if (< (- (len seq) start) (len pat))
152 | nil
153 | (if (headmatch pat seq start)
154 | start
155 | (findsubseq pat seq (+ start 1)))))
156 |
157 | (def blank (s) (~find ~whitec s))
158 |
159 | (def nonblank (s) (unless (blank s) s))
160 |
161 | (def trim (s (o where 'both) (o test whitec))
162 | (withs (f (testify test)
163 | p1 (pos ~f s))
164 | (if p1
165 | (cut s
166 | (if (in where 'front 'both) p1 0)
167 | (when (in where 'end 'both)
168 | (let i (- (len s) 1)
169 | (while (and (> i p1) (f (s i)))
170 | (-- i))
171 | (+ i 1))))
172 | "")))
173 |
174 | (def num (n (o digits 2) (o trail-zeros nil) (o init-zero nil))
175 | (withs (comma
176 | (fn (i)
177 | (tostring
178 | (map [apply pr (rev _)]
179 | (rev (intersperse '(#\,)
180 | (tuples (rev (coerce (string i) 'cons))
181 | 3))))))
182 | abrep
183 | (let a (abs n)
184 | (if (< digits 1)
185 | (comma (roundup a))
186 | (exact a)
187 | (string (comma a)
188 | (when (and trail-zeros (> digits 0))
189 | (string "." (newstring digits #\0))))
190 | (withs (d (expt 10 digits)
191 | m (/ (roundup (* a d)) d)
192 | i (trunc m)
193 | r (abs (trunc (- (* m d) (* i d)))))
194 | (+ (if (is i 0)
195 | (if (or init-zero (is r 0)) "0" "")
196 | (comma i))
197 | (withs (rest (string r)
198 | padded (+ (newstring (- digits (len rest)) #\0)
199 | rest)
200 | final (if trail-zeros
201 | padded
202 | (trim padded 'end [is _ #\0])))
203 | (string (unless (empty final) ".")
204 | final)))))))
205 | (if (and (< n 0) (find [and (digit _) (isnt _ #\0)] abrep))
206 | (+ "-" abrep)
207 | abrep)))
208 |
209 |
210 | ; English
211 |
212 | (def pluralize (n str)
213 | (if (or (is n 1) (single n))
214 | str
215 | (string str "s")))
216 |
217 | (def plural (n x)
218 | (string n #\ (pluralize n x)))
219 |
220 |
221 | ; http://www.eki.ee/letter/chardata.cgi?HTML4=1
222 | ; http://jrgraphix.net/research/unicode_blocks.php?block=1
223 | ; http://home.tiscali.nl/t876506/utf8tbl.html
224 | ; http://www.fileformat.info/info/unicode/block/latin_supplement/utf8test.htm
225 | ; http://en.wikipedia.org/wiki/Utf-8
226 | ; http://unicode.org/charts/charindex2.html
227 |
--------------------------------------------------------------------------------
/arc3.1/table-rw3.arc:
--------------------------------------------------------------------------------
1 | ; http://awwx.ws/table-rw3
2 | ; modified!
3 |
4 | (def parse-table-items (port (o acc nil))
5 | ((scheme skip-whitespace) port)
6 | (if (is (peekc port) #\})
7 | (do (readc port) `(obj ,@(rev acc)))
8 | (let x (read port)
9 | (push x acc)
10 | (parse-table-items port acc))))
11 |
12 | (extend-readtable #\{ parse-table-items)
13 |
--------------------------------------------------------------------------------