arc0 vs arc3.1

inline | arc0 | arc3.1

September 2015

This is a comparison of the first release of Arc to the latest version. Arc's codebase is an instance of bottom-up design: much of the code in the original is still present in the latest, and the diffs are mostly feature additions and bug fixes rather than refactors or rewrites.

Arc's compiler is written in Scheme, but the language itself is mostly written in Arc. This is possible because the compiler (ac.scm) provides a minimal set of basic features, like the ability to manipulate strings and lists, the ability to construct a function, and so on. Using these basic abilities, the language is able to define itself in arc.arc. It builds itself up similar to geometry: it uses the "axioms" provided by the compiler (assignment, comparison, etc) to define the various "theorems" of the language, like what it means to define a function or to declare a variable. And since your program is written in Arc, just like the language, you can do all of the same things that arc.arc does. You can bend the language into whatever shape is most convenient for your program. This design has a number of benefits, yielding a brief language with a short compiler.

Arc expressions are compiled to Scheme via the "ac" function, and the result is executed using eval. The original codebase runs on MzScheme 372, and the latest runs on Racket.

Left: arc0.tar
1,157 lines of Scheme (Arc compiler)
3,450 lines of Arc (core language + stdlibs)

Right: arc3.1.tar
1,553 lines of Scheme (Arc compiler)
3,946 lines of Arc (core language + stdlibs)
2,618 lines of Arc (news.arc, HN's early codebase)

Unfortunately, I wasn't able to find arc1.tar, arc2.tar, or arc3.tar. Their download URLs broke long ago, and archive.org doesn't seem to have any copies. If you happen to have any of them, I would be very grateful if you'd send a copy to sudoarc@gmail.com. news.arc is absent from arc0, making it difficult to trace HN's evolutionary path.

nonums

1	./ac.scm	=	1	./ac.scm
2	; scheme48	<>
3	; ,open tables sockets extended-ports c-system-function ascii i/o-internal
4	; ,open posix-files handle random pp simple-conditions
5			2	; Arc Compiler.
6	; to do:
7	; select, perhaps with threads, or pltt events
8	; check argument count for complex arguments
9		=	3
10	; refs.arc, first 300 lines of x, total CPU time including startup. on powerbook.	+-
11	; scheme48: 31.944u 0.518s 2:13.65 24.2% 0+0k 5+7io 0pf+0w
12	; mzscheme: 16.425u 0.489s 0:52.61 32.1% 0+0k 26+22io 0pf+0w
13
14	; dynamic creation of local variables with =
15	; can you create globals inside a procedure?
16	; does action of = depend on whether, at run time,
17	; the variable has a global definition?
18	; what's the scope of such a variable?
19	; though a.lisp seems to create a global, not a local!
20	; run-time expansion of macros
21	; how do I know if something is a macro at compile time?
22	; macros have lexical scope. so how do i know if a lexical
23	; variable is going to be bound to a procedure? or to a macro?
24	; what is annotate doing to symbols?
25	; tests.arc implies that '(a b) produces a mutable list
26	; so (fn () '(a)) produces a list that can be modified,
27	; and future calls will reflect the modifications
28	; oy. clisp works this way too.
29	; it's not that easy to simulate this.
30	; what is this? (def foo1 (x (o y x)) (list x y))
31
32	; it's not clear I translate NILs in the outputs of macros correctly.
33	; I translate (NIL . NIL) to ('NIL . '())
34	; I use Scheme apply to call macros.
35	; Scheme apply demands a '()-terminated list.
36	; most macros have a . body argument.
37	; so body is '()-terminated, not NIL-terminated.
38	; solution: ar-false? knows about '()
39	; this doesn't work, since var isn't a variable name:
40	; (mac or args
41	; (and args
42	; (let var (tag 'symbol (list 'or))
43	; (list 'let var (car args)
44	; (list 'if var var (cons 'or (cdr args)))))))
45
46	(module ac mzscheme	=	4	(module ac mzscheme
47			5
48	(provide (all-defined))		6	(provide (all-defined))
49	(require (lib "port.ss"))		7	(require (lib "port.ss"))
50	(require (lib "process.ss"))		8	(require (lib "process.ss"))
51	(require (lib "pretty.ss"))		9	(require (lib "pretty.ss"))
		-+	10	(require (lib "foreign.ss"))
			11	(unsafe!)
52		=	12
53	; compile an Arc expression into a Scheme expression,		13	; compile an Arc expression into a Scheme expression,
54	; both represented as s-expressions.		14	; both represented as s-expressions.
55	; env is a list of lexically bound variables, which we		15	; env is a list of lexically bound variables, which we
56	; need in order to decide whether set should create a global.		16	; need in order to decide whether set should create a global.
57			17
58	(define (ac s env)		18	(define (ac s env)
59	(cond ((string? s) (string-copy s)) ; to avoid immutable strings	<>	19	(cond ((string? s) (ac-string s env))
60	((literal? s) s)	=	20	((literal? s) s)
61	((eqv? s 'nil) (list 'quote 'nil))		21	((eqv? s 'nil) (list 'quote 'nil))
62	((ssyntax? s) (ac (expand-ssyntax s) env))		22	((ssyntax? s) (ac (expand-ssyntax s) env))
63	((symbol? s) (ac-var-ref s env))		23	((symbol? s) (ac-var-ref s env))
64	((ssyntax? (xcar s)) (ac (cons (expand-ssyntax (car s)) (cdr s)) env))		24	((ssyntax? (xcar s)) (ac (cons (expand-ssyntax (car s)) (cdr s)) env))
65	((eq? (xcar s) 'quote) (list 'quote (ac-niltree (cadr s))))		25	((eq? (xcar s) 'quote) (list 'quote (ac-niltree (cadr s))))
66	((eq? (xcar s) 'quasiquote) (ac-qq (cadr s) env))		26	((eq? (xcar s) 'quasiquote) (ac-qq (cadr s) env))
67	((eq? (xcar s) 'if) (ac-if (cdr s) env))		27	((eq? (xcar s) 'if) (ac-if (cdr s) env))
68	((eq? (xcar s) 'fn) (ac-fn (cadr s) (cddr s) env))		28	((eq? (xcar s) 'fn) (ac-fn (cadr s) (cddr s) env))
69	((eq? (xcar s) 'set) (ac-set (cdr s) env))	<>	29	((eq? (xcar s) 'assign) (ac-set (cdr s) env))
70	; this line could be removed without changing semantics		30	; the next three clauses could be removed without changing semantics
			31	; ... except that they work for macros (so prob should do this for
			32	; every elt of s, not just the car)
71	((eq? (xcar (xcar s)) 'compose) (ac (decompose (cdar s) (cdr s)) env))	=	33	((eq? (xcar (xcar s)) 'compose) (ac (decompose (cdar s) (cdr s)) env))
		-+	34	((eq? (xcar (xcar s)) 'complement)
			35	(ac (list 'no (cons (cadar s) (cdr s))) env))
			36	((eq? (xcar (xcar s)) 'andf) (ac-andf s env))
72	((pair? s) (ac-call (car s) (cdr s) env))	=	37	((pair? s) (ac-call (car s) (cdr s) env))
73	(#t (err "Bad object in expression" s))))		38	(#t (err "Bad object in expression" s))))
		-+	39
			40	(define atstrings #f)
			41
			42	(define (ac-string s env)
			43	(if atstrings
			44	(if (atpos s 0)
			45	(ac (cons 'string (map (lambda (x)
			46	(if (string? x)
			47	(unescape-ats x)
			48	x))
			49	(codestring s)))
			50	env)
			51	(unescape-ats s))
			52	(string-copy s))) ; avoid immutable strings
74		=	53
75	(define (literal? x)		54	(define (literal? x)
76	(or (boolean? x)		55	(or (boolean? x)
77	(char? x)		56	(char? x)
78	(string? x)		57	(string? x)
79	(number? x)		58	(number? x)
80	(eq? x '())))		59	(eq? x '())))
81			60
82	(define (ssyntax? x)		61	(define (ssyntax? x)
83	(and (symbol? x)		62	(and (symbol? x)
84	(not (or (eqv? x '+) (eqv? x '++)))	<>	63	(not (or (eqv? x '+) (eqv? x '++) (eqv? x '_)))
85	(let ((name (symbol->string x)))	=	64	(let ((name (symbol->string x)))
86	(has-ssyntax-char? name (- (string-length name) 1)))))		65	(has-ssyntax-char? name (- (string-length name) 1)))))
87			66
88	(define (has-ssyntax-char? string i)		67	(define (has-ssyntax-char? string i)
89	(and (>= i 0)		68	(and (>= i 0)
90	(or (let ((c (string-ref string i)))		69	(or (let ((c (string-ref string i)))
91	(or (eqv? c #\:) (eqv? c #\~)))	<>	70	(or (eqv? c #\:) (eqv? c #\~)
			71	(eqv? c #\&)
			72	;(eqv? c #\_)
			73	(eqv? c #\.) (eqv? c #\!)))
92	(has-ssyntax-char? string (- i 1)))))	=	74	(has-ssyntax-char? string (- i 1)))))
93			75
94	(define (read-from-string str)		76	(define (read-from-string str)
95	(let ((port (open-input-string str)))		77	(let ((port (open-input-string str)))
96	(let ((val (read port)))		78	(let ((val (read port)))
97	(close-input-port port)		79	(close-input-port port)
98	val)))		80	val)))
99			81
		-+	82	; Though graphically the right choice, can't use _ for currying
			83	; because then _!foo becomes a function. Maybe use <>. For now
			84	; leave this off and see how often it would have been useful.
			85
			86	; Might want to make ~ have less precedence than &, because
			87	; ~foo&bar prob should mean (andf (complement foo) bar), not
			88	; (complement (andf foo bar)).
			89
100	(define (expand-ssyntax sym)	=	90	(define (expand-ssyntax sym)
		-+	91	((cond ((or (insym? #\: sym) (insym? #\~ sym)) expand-compose)
			92	((or (insym? #\. sym) (insym? #\! sym)) expand-sexpr)
			93	((insym? #\& sym) expand-and)
			94	; ((insym? #\_ sym) expand-curry)
			95	(#t (error "Unknown ssyntax" sym)))
			96	sym))
			97
			98	(define (expand-compose sym)
101	(let ((elts (map (lambda (tok)	=	99	(let ((elts (map (lambda (tok)
102	(if (eqv? (car tok) #\~)		100	(if (eqv? (car tok) #\~)
		<>	101	(if (null? (cdr tok))
			102	'no
103	`(complement ,(chars->value (cdr tok)))		103	`(complement ,(chars->value (cdr tok))))
104	(chars->value tok)))	=	104	(chars->value tok)))
		<>	105	(tokens (lambda (c) (eqv? c #\:))
105	(tokens #\: (symbol->chars sym) '() '()))))		106	(symbol->chars sym)
			107	'()
			108	'()
			109	#f))))
106	(if (null? (cdr elts))	=	110	(if (null? (cdr elts))
107	(car elts)		111	(car elts)
108	(cons 'compose elts))))		112	(cons 'compose elts))))
109			113
		-+	114	(define (expand-and sym)
			115	(let ((elts (map chars->value
			116	(tokens (lambda (c) (eqv? c #\&))
			117	(symbol->chars sym)
			118	'()
			119	'()
			120	#f))))
			121	(if (null? (cdr elts))
			122	(car elts)
			123	(cons 'andf elts))))
			124
			125	; How to include quoted arguments? Can't treat all as quoted, because
			126	; never want to quote fn given as first. Do we want to allow quote chars
			127	; within symbols? Could be ugly.
			128
			129	; If release, fix the fact that this simply uses v0... as vars. Should
			130	; make these vars gensyms.
			131
			132	(define (expand-curry sym)
			133	(let ((expr (exc (map (lambda (x)
			134	(if (pair? x) (chars->value x) x))
			135	(tokens (lambda (c) (eqv? c #\_))
			136	(symbol->chars sym)
			137	'()
			138	'()
			139	#t))
			140	0)))
			141	(list 'fn
			142	(keep (lambda (s)
			143	(and (symbol? s)
			144	(eqv? (string-ref (symbol->string s) 0)
			145	#\v)))
			146	expr)
			147	expr)))
			148
			149	(define (keep f xs)
			150	(cond ((null? xs) '())
			151	((f (car xs)) (cons (car xs) (keep f (cdr xs))))
			152	(#t (keep f (cdr xs)))))
			153
			154	(define (exc elts n)
			155	(cond ((null? elts)
			156	'())
			157	((eqv? (car elts) #\_)
			158	(cons (string->symbol (string-append "v" (number->string n)))
			159	(exc (cdr elts) (+ n 1))))
			160	(#t
			161	(cons (car elts) (exc (cdr elts) n)))))
			162
			163	(define (expand-sexpr sym)
			164	(build-sexpr (reverse (tokens (lambda (c) (or (eqv? c #\.) (eqv? c #\!)))
			165	(symbol->chars sym)
			166	'()
			167	'()
			168	#t))
			169	sym))
			170
			171	(define (build-sexpr toks orig)
			172	(cond ((null? toks)
			173	'get)
			174	((null? (cdr toks))
			175	(chars->value (car toks)))
			176	(#t
			177	(list (build-sexpr (cddr toks) orig)
			178	(if (eqv? (cadr toks) #\!)
			179	(list 'quote (chars->value (car toks)))
			180	(if (or (eqv? (car toks) #\.) (eqv? (car toks) #\!))
			181	(err "Bad ssyntax" orig)
			182	(chars->value (car toks))))))))
			183
			184	(define (insym? char sym) (member char (symbol->chars sym)))
			185
110	(define (symbol->chars x) (string->list (symbol->string x)))	=	186	(define (symbol->chars x) (string->list (symbol->string x)))
111			187
112	(define (chars->value chars) (read-from-string (list->string chars)))		188	(define (chars->value chars) (read-from-string (list->string chars)))
113			189
114	; result will contain \|\| if separator at end of symbol; could use	<>
115	; that to mean something
116
117	(define (tokens separator source token acc)		190	(define (tokens test source token acc keepsep?)
118	(cond ((null? source)	=	191	(cond ((null? source)
		<>	192	(reverse (if (pair? token)
119	(reverse (cons (reverse token) acc)))		193	(cons (reverse token) acc)
			194	acc)))
120	((eqv? (car source) separator)		195	((test (car source))
121	(tokens separator		196	(tokens test
122	(cdr source)	=	197	(cdr source)
123	'()		198	'()
		<>	199	(let ((rec (if (null? token)
			200	acc
124	(cons (reverse token) acc)))		201	(cons (reverse token) acc))))
			202	(if keepsep?
			203	(cons (car source) rec)
			204	rec))
			205	keepsep?))
125	(#t	=	206	(#t
126	(tokens separator	<>	207	(tokens test
127	(cdr source)	=	208	(cdr source)
128	(cons (car source) token)		209	(cons (car source) token)
129	acc))))	<>	210	acc
130			211	keepsep?))))
131	; Purely an optimization. Could in principle do it with a preprocessor
132	; instead of adding a line to ac, but only want to do it for evaluated
133	; subtrees, and much easier to figure those out in ac.
134
135	(define (decompose fns args)
136	(cond ((null? fns) `((fn vals (car vals)) ,@args))
137	((null? (cdr fns)) (cons (car fns) args))
138	(#t (list (car fns) (decompose (cdr fns) args)))))
139
140		=	212
141	(define (ac-global-name s)		213	(define (ac-global-name s)
142	(string->symbol (string-append "_" (symbol->string s))))		214	(string->symbol (string-append "_" (symbol->string s))))
143			215
144	(define (ac-var-ref s env)		216	(define (ac-var-ref s env)
145	(if (lex? s env)		217	(if (lex? s env)
146	s		218	s
147	(ac-global-name s)))		219	(ac-global-name s)))
148			220
149	; quasiquote		221	; quasiquote
150			222
151	(define (ac-qq args env)		223	(define (ac-qq args env)
152	(list 'quasiquote (ac-qq1 1 args env)))		224	(list 'quasiquote (ac-qq1 1 args env)))
153			225
154	; process the argument of a quasiquote. keep track of		226	; process the argument of a quasiquote. keep track of
155	; depth of nesting. handle unquote only at top level (level = 1).		227	; depth of nesting. handle unquote only at top level (level = 1).
156	; complete form, e.g. x or (fn x) or (unquote (fn x))		228	; complete form, e.g. x or (fn x) or (unquote (fn x))
		-+	229
157	(define (ac-qq1 level x env)	=	230	(define (ac-qq1 level x env)
158	(cond ((= level 0)		231	(cond ((= level 0)
159	(ac x env))		232	(ac x env))
160	((and (pair? x) (eqv? (car x) 'unquote))		233	((and (pair? x) (eqv? (car x) 'unquote))
161	(list 'unquote (ac-qq1 (- level 1) (cadr x) env)))		234	(list 'unquote (ac-qq1 (- level 1) (cadr x) env)))
162	((and (pair? x) (eqv? (car x) 'unquote-splicing) (= level 1))		235	((and (pair? x) (eqv? (car x) 'unquote-splicing) (= level 1))
163	(list 'unquote-splicing		236	(list 'unquote-splicing
164	(list 'ar-nil-terminate (ac-qq1 (- level 1) (cadr x) env))))		237	(list 'ar-nil-terminate (ac-qq1 (- level 1) (cadr x) env))))
165	((and (pair? x) (eqv? (car x) 'quasiquote))		238	((and (pair? x) (eqv? (car x) 'quasiquote))
166	(list 'quasiquote (ac-qq1 (+ level 1) (cadr x) env)))		239	(list 'quasiquote (ac-qq1 (+ level 1) (cadr x) env)))
167	((pair? x)		240	((pair? x)
168	(map (lambda (x) (ac-qq1 level x env)) x))	<>	241	(imap (lambda (x) (ac-qq1 level x env)) x))
169	(#t x)))	=	242	(#t x)))
		-+	243
			244	; like map, but don't demand '()-terminated list
			245
			246	(define (imap f l)
			247	(cond ((pair? l)
			248	(cons (f (car l)) (imap f (cdr l))))
			249	((null? l)
			250	'())
			251	(#t (f l))))
170		=	252
171	; (if) -> nil		253	; (if) -> nil
172	; (if x) -> x		254	; (if x) -> x
173	; (if t a ...) -> a		255	; (if t a ...) -> a
174	; (if nil a b) -> b		256	; (if nil a b) -> b
175	; (if nil a b c) -> (if b c)		257	; (if nil a b c) -> (if b c)
176			258
177	(define (ac-if args env)		259	(define (ac-if args env)
178	(cond ((null? args) ''nil)		260	(cond ((null? args) ''nil)
179	((null? (cdr args)) (ac (car args) env))		261	((null? (cdr args)) (ac (car args) env))
180	(#t `(if (not (ar-false? ,(ac (car args) env)))		262	(#t `(if (not (ar-false? ,(ac (car args) env)))
181	;(not (eq? 'nil ,(ac (car args) env)))	+-
182	,(ac (cadr args) env)	=	263	,(ac (cadr args) env)
183	,(ac-if (cddr args) env)))))		264	,(ac-if (cddr args) env)))))
184			265
		-+	266	(define (ac-dbname! name env)
			267	(if (symbol? name)
			268	(cons (list name) env)
			269	env))
			270
			271	(define (ac-dbname env)
			272	(cond ((null? env) #f)
			273	((pair? (car env)) (caar env))
			274	(#t (ac-dbname (cdr env)))))
			275
185	; translate fn directly into a lambda if it has ordinary	=	276	; translate fn directly into a lambda if it has ordinary
186	; parameters, otherwise use a rest parameter and parse it.		277	; parameters, otherwise use a rest parameter and parse it.
		-+	278
187	(define (ac-fn args body env)	=	279	(define (ac-fn args body env)
188	(if (ac-complex-args? args)		280	(if (ac-complex-args? args)
189	(ac-complex-fn args body env)		281	(ac-complex-fn args body env)
		<>	282	(ac-nameit
			283	(ac-dbname env)
190	`(lambda ,(let ((a (ac-denil args))) (if (eqv? a 'nil) '() a))		284	`(lambda ,(let ((a (ac-denil args))) (if (eqv? a 'nil) '() a))
191	'nil
192	,@(ac-body body (append (ac-arglist args) env)))))		285	,@(ac-body* body (append (ac-arglist args) env))))))
193		=	286
194	; does an fn arg list use optional parameters or destructuring?		287	; does an fn arg list use optional parameters or destructuring?
195	; a rest parameter is not complex		288	; a rest parameter is not complex
		-+	289
196	(define (ac-complex-args? args)	=	290	(define (ac-complex-args? args)
197	(cond ((eqv? args '()) #f)		291	(cond ((eqv? args '()) #f)
198	((symbol? args) #f)		292	((symbol? args) #f)
199	((and (pair? args) (symbol? (car args)))		293	((and (pair? args) (symbol? (car args)))
200	(ac-complex-args? (cdr args)))		294	(ac-complex-args? (cdr args)))
201	(#t #t)))		295	(#t #t)))
202			296
203	; translate a fn with optional or destructuring args		297	; translate a fn with optional or destructuring args
204	; (fn (x (o y x) (o z 21) (x1 x2) . rest) ...)		298	; (fn (x (o y x) (o z 21) (x1 x2) . rest) ...)
205	; arguments in top-level list are mandatory (unless optional),		299	; arguments in top-level list are mandatory (unless optional),
206	; but it's OK for parts of a list you're destructuring to		300	; but it's OK for parts of a list you're destructuring to
207	; be missing.		301	; be missing.
		-+	302
208	(define (ac-complex-fn args body env)	=	303	(define (ac-complex-fn args body env)
209	(let* ((ra (ar-gensym))		304	(let* ((ra (ar-gensym))
210	(z (ac-complex-args args env ra #t)))		305	(z (ac-complex-args args env ra #t)))
211	`(lambda ,ra		306	`(lambda ,ra
212	(let* ,z		307	(let* ,z
213	'nil	<>
214	,@(ac-body body (append (ac-complex-getargs z) env))))))		308	,@(ac-body* body (append (ac-complex-getargs z) env))))))
215		=	309
216	; returns a list of two-element lists, first is variable name,		310	; returns a list of two-element lists, first is variable name,
217	; second is (compiled) expression. to be used in a let.		311	; second is (compiled) expression. to be used in a let.
218	; caller should extract variables and add to env.		312	; caller should extract variables and add to env.
219	; ra is the rest argument to the fn.		313	; ra is the rest argument to the fn.
220	; is-params indicates that args are function arguments		314	; is-params indicates that args are function arguments
221	; (not destructuring), so they must be passed or be optional.		315	; (not destructuring), so they must be passed or be optional.
		-+	316
222	(define (ac-complex-args args env ra is-params)	=	317	(define (ac-complex-args args env ra is-params)
223	(cond ((or (eqv? args '()) (eqv? args 'nil)) '())		318	(cond ((or (eqv? args '()) (eqv? args 'nil)) '())
224	((symbol? args) (list (list args ra)))		319	((symbol? args) (list (list args ra)))
225	((pair? args)		320	((pair? args)
226	(let* ((x (if (and (pair? (car args)) (eqv? (caar args) 'o))		321	(let* ((x (if (and (pair? (car args)) (eqv? (caar args) 'o))
227	(ac-complex-opt (cadar args)		322	(ac-complex-opt (cadar args)
228	(if (pair? (cddar args))		323	(if (pair? (cddar args))
229	(caddar args)		324	(caddar args)
230	'nil)		325	'nil)
231	env		326	env
232	ra)		327	ra)
233	(ac-complex-args		328	(ac-complex-args
234	(car args)		329	(car args)
235	env		330	env
236	(if is-params		331	(if is-params
237	`(car ,ra)		332	`(car ,ra)
238	`(ar-xcar ,ra))		333	`(ar-xcar ,ra))
239	#f)))		334	#f)))
240	(xa (ac-complex-getargs x)))		335	(xa (ac-complex-getargs x)))
241	(append x (ac-complex-args (cdr args)		336	(append x (ac-complex-args (cdr args)
242	(append xa env)		337	(append xa env)
243	`(ar-xcdr ,ra)		338	`(ar-xcdr ,ra)
244	is-params))))		339	is-params))))
245	(#t (err "Can't understand fn arg list" args))))		340	(#t (err "Can't understand fn arg list" args))))
246			341
247	; (car ra) is the argument		342	; (car ra) is the argument
248	; so it's not present if ra is nil or '()		343	; so it's not present if ra is nil or '()
		-+	344
249	(define (ac-complex-opt var expr env ra)	=	345	(define (ac-complex-opt var expr env ra)
250	(list (list var `(if (pair? ,ra) (car ,ra) ,(ac expr env)))))		346	(list (list var `(if (pair? ,ra) (car ,ra) ,(ac expr env)))))
251			347
252	; extract list of variables from list of two-element lists.		348	; extract list of variables from list of two-element lists.
		-+	349
253	(define (ac-complex-getargs a)	=	350	(define (ac-complex-getargs a)
254	(map (lambda (x) (car x)) a))		351	(map (lambda (x) (car x)) a))
255			352
256	; (a b . c) -> (a b c)		353	; (a b . c) -> (a b c)
257	; a -> (a)		354	; a -> (a)
		-+	355
258	(define (ac-arglist a)	=	356	(define (ac-arglist a)
259	(cond ((null? a) '())		357	(cond ((null? a) '())
260	((symbol? a) (list a))		358	((symbol? a) (list a))
261	((symbol? (cdr a)) (list (car a) (cdr a)))		359	((symbol? (cdr a)) (list (car a) (cdr a)))
262	(#t (cons (car a) (ac-arglist (cdr a))))))		360	(#t (cons (car a) (ac-arglist (cdr a))))))
263			361
264	(define (ac-body body env)		362	(define (ac-body body env)
		-+	363	(map (lambda (x) (ac x env)) body))
			364
			365	; like ac-body, but spits out a nil expression if empty
			366
			367	(define (ac-body* body env)
265	(if (null? body)	=	368	(if (null? body)
266	'()	<>	369	(list (list 'quote 'nil))
267	(cons (ac (car body) env) (ac-body (cdr body) env))))		370	(ac-body body env)))
268		=	371
269	; (set v1 expr1 v2 expr2 ...)		372	; (set v1 expr1 v2 expr2 ...)
270			373
271	(define (ac-set x env)		374	(define (ac-set x env)
272	`(begin ,@(ac-setn x env)))		375	`(begin ,@(ac-setn x env)))
273			376
274	(define (ac-setn x env)		377	(define (ac-setn x env)
275	(if (null? x)		378	(if (null? x)
276	'()		379	'()
277	(cons (ac-set1 (ac-macex (car x)) (ac (cadr x) env) env)	<>	380	(cons (ac-set1 (ac-macex (car x)) (cadr x) env)
278	(ac-setn (cddr x) env))))	=	381	(ac-setn (cddr x) env))))
279			382
		-+	383	; trick to tell Scheme the name of something, so Scheme
			384	; debugging and profiling make more sense.
			385
			386	(define (ac-nameit name v)
			387	(if (symbol? name)
			388	(let ((n (string->symbol (string-append " " (symbol->string name)))))
			389	(list 'let `((,n ,v)) n))
			390	v))
			391
280	; = replaced by set, which is only for vars	=	392	; = replaced by set, which is only for vars
281	; = now defined in arc (is it?)		393	; = now defined in arc (is it?)
282	; name is to cause fns to have their arc names for debugging		394	; name is to cause fns to have their arc names for debugging
283			395
284	(define (ac-set1 a b env)	<>	396	(define (ac-set1 a b1 env)
285	(if (symbol? a)	=	397	(if (symbol? a)
286	(let ((name (string->symbol (string-append " " (symbol->string a)))))	<>	398	(let ((b (ac b1 (ac-dbname! a env))))
287	(list 'let `((,name ,b))		399	(list 'let `((zz ,b))
288	(cond ((eqv? a 'nil) (err "Can't rebind nil"))	=	400	(cond ((eqv? a 'nil) (err "Can't rebind nil"))
289	((eqv? a 't) (err "Can't rebind t"))		401	((eqv? a 't) (err "Can't rebind t"))
290	((lex? a env) `(set! ,a ,name))	<>	402	((lex? a env) `(set! ,a zz))
291	(#t `(namespace-set-variable-value! ',(ac-global-name a)	=	403	(#t `(namespace-set-variable-value! ',(ac-global-name a)
292	,name)))	<>	404	zz)))
293	name))		405	'zz))
294	(err "First arg to set must be a symbol" a)))	=	406	(err "First arg to set must be a symbol" a)))
		-+	407
			408	; given a list of Arc expressions, return a list of Scheme expressions.
			409	; for compiling passed arguments.
			410
			411	(define (ac-args names exprs env)
			412	(if (null? exprs)
			413	'()
			414	(cons (ac (car exprs)
			415	(ac-dbname! (if (pair? names) (car names) #f) env))
			416	(ac-args (if (pair? names) (cdr names) '())
			417	(cdr exprs)
			418	env))))
			419
			420	; generate special fast code for ordinary two-operand
			421	; calls to the following functions. this is to avoid
			422	; calling e.g. ar-is with its &rest and apply.
			423
			424	(define ac-binaries
			425	'((is ar-is2)
			426	(< ar-<2)
			427	(> ar->2)
			428	(+ ar-+2)))
			429
			430	; (foo bar) where foo is a global variable bound to a procedure.
			431
			432	(define (ac-global-call fn args env)
			433	(cond ((and (assoc fn ac-binaries) (= (length args) 2))
			434	`(,(cadr (assoc fn ac-binaries)) ,@(ac-args '() args env)))
			435	(#t
			436	`(,(ac-global-name fn) ,@(ac-args '() args env)))))
295		=	437
296	; compile a function call		438	; compile a function call
297	; special cases for speed, to avoid compiled output like		439	; special cases for speed, to avoid compiled output like
298	; (ar-apply _pr (list 1 2))		440	; (ar-apply _pr (list 1 2))
299	; which results in 1/2 the CPU time going to GC. Instead:		441	; which results in 1/2 the CPU time going to GC. Instead:
300	; (ar-funcall2 _pr 1 2)		442	; (ar-funcall2 _pr 1 2)
		-+	443	; and for (foo bar), if foo is a reference to a global variable,
			444	; and it's bound to a function, generate (foo bar) instead of
			445	; (ar-funcall1 foo bar)
			446
			447	(define direct-calls #f)
			448
301	(define (ac-call fn args env)	=	449	(define (ac-call fn args env)
302	(let ((macfn (ac-macro? fn)))		450	(let ((macfn (ac-macro? fn)))
303	(cond (macfn		451	(cond (macfn
304	(ac-mac-call macfn args env))		452	(ac-mac-call macfn args env))
305	((and (pair? fn) (eqv? (car fn) 'fn))		453	((and (pair? fn) (eqv? (car fn) 'fn))
306	`(,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))	<>	454	`(,(ac fn env) ,@(ac-args (cadr fn) args env)))
			455	((and direct-calls (symbol? fn) (not (lex? fn env)) (bound? fn)
			456	(procedure? (namespace-variable-value (ac-global-name fn))))
			457	(ac-global-call fn args env))
307	((= (length args) 0)	=	458	((= (length args) 0)
308	`(ar-funcall0 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))		459	`(ar-funcall0 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
309	((= (length args) 1)		460	((= (length args) 1)
310	`(ar-funcall1 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))		461	`(ar-funcall1 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
311	((= (length args) 2)		462	((= (length args) 2)
312	`(ar-funcall2 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))		463	`(ar-funcall2 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
313	((= (length args) 3)		464	((= (length args) 3)
314	`(ar-funcall3 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))		465	`(ar-funcall3 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
315	((= (length args) 4)		466	((= (length args) 4)
316	`(ar-funcall4 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))		467	`(ar-funcall4 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
317	(#t		468	(#t
318	`(ar-apply ,(ac fn env)		469	`(ar-apply ,(ac fn env)
319	(list ,@(map (lambda (x) (ac x env)) args)))))))		470	(list ,@(map (lambda (x) (ac x env)) args)))))))
320			471
321	(define (ac-mac-call m args env)		472	(define (ac-mac-call m args env)
322	(let ((x1 (apply m (map ac-niltree args))))		473	(let ((x1 (apply m (map ac-niltree args))))
323	(let ((x2 (ac (ac-denil x1) env)))		474	(let ((x2 (ac (ac-denil x1) env)))
324	x2)))		475	x2)))
325			476
326	; returns #f or the macro function		477	; returns #f or the macro function
327			478
328	(define (ac-macro? fn)		479	(define (ac-macro? fn)
329	(if (symbol? fn)		480	(if (symbol? fn)
330	(let ((v (namespace-variable-value (ac-global-name fn)		481	(let ((v (namespace-variable-value (ac-global-name fn)
331	#t		482	#t
332	(lambda () #f))))		483	(lambda () #f))))
333	(if (and v		484	(if (and v
334	(ar-tagged? v)		485	(ar-tagged? v)
335	(eq? (ar-type v) 'mac))		486	(eq? (ar-type v) 'mac))
336	(ar-rep v)		487	(ar-rep v)
337	#f))		488	#f))
338	#f))		489	#f))
339			490
340	; macroexpand the outer call of a form as much as possible		491	; macroexpand the outer call of a form as much as possible
341			492
342	(define (ac-macex e . once)		493	(define (ac-macex e . once)
343	(if (pair? e)		494	(if (pair? e)
344	(let ((m (ac-macro? (car e))))		495	(let ((m (ac-macro? (car e))))
345	(if m		496	(if m
346	(let ((expansion (ac-denil (apply m (map ac-niltree (cdr e))))))		497	(let ((expansion (ac-denil (apply m (map ac-niltree (cdr e))))))
347	(if (null? once) (ac-macex expansion) expansion))		498	(if (null? once) (ac-macex expansion) expansion))
348	e))		499	e))
349	e))		500	e))
350			501
351	; macros return Arc lists, ending with NIL.		502	; macros return Arc lists, ending with NIL.
352	; but the Arc compiler expects Scheme lists, ending with '().		503	; but the Arc compiler expects Scheme lists, ending with '().
353	; what to do with (is x nil . nil) ?		504	; what to do with (is x nil . nil) ?
354	; the first nil ought to be replaced with 'NIL		505	; the first nil ought to be replaced with 'NIL
355	; the second with '()		506	; the second with '()
356	; so the rule is: NIL in the car -> 'NIL, NIL in the cdr -> '().		507	; so the rule is: NIL in the car -> 'NIL, NIL in the cdr -> '().
357	; NIL by itself -> NIL		508	; NIL by itself -> NIL
358			509
359	(define (ac-denil x)		510	(define (ac-denil x)
360	(cond ((pair? x) (cons (ac-denil-car (car x)) (ac-denil-cdr (cdr x))))		511	(cond ((pair? x) (cons (ac-denil-car (car x)) (ac-denil-cdr (cdr x))))
361	(#t x)))		512	(#t x)))
362			513
363	(define (ac-denil-car x)		514	(define (ac-denil-car x)
364	(if (eq? x 'nil)		515	(if (eq? x 'nil)
365	'nil		516	'nil
366	(ac-denil x)))		517	(ac-denil x)))
367			518
368	(define (ac-denil-cdr x)		519	(define (ac-denil-cdr x)
369	(if (eq? x 'nil)		520	(if (eq? x 'nil)
370	'()		521	'()
371	(ac-denil x)))		522	(ac-denil x)))
372			523
373	; is v lexically bound?		524	; is v lexically bound?
		-+	525
374	(define (lex? v env)	=	526	(define (lex? v env)
375	(memq v env))		527	(memq v env))
376			528
377	(define (xcar x)		529	(define (xcar x)
378	(and (pair? x) (car x)))		530	(and (pair? x) (car x)))
379			531
380	; #f and '() -> nil for a whole quoted list/tree.		532	; #f and '() -> nil for a whole quoted list/tree.
381			533
		-+	534	; Arc primitives written in Scheme should look like:
			535
			536	; (xdef foo (lambda (lst)
			537	; (ac-niltree (scheme-foo (ar-nil-terminate lst)))))
			538
			539	; That is, Arc lists are NIL-terminated. When calling a Scheme
			540	; function that treats an argument as a list, call ar-nil-terminate
			541	; to change NIL to '(). When returning any data created by Scheme
			542	; to Arc, call ac-niltree to turn all '() into NIL.
			543	; (hash-table-get doesn't use its argument as a list, so it doesn't
			544	; need ar-nil-terminate).
			545
382	(define (ac-niltree x)	=	546	(define (ac-niltree x)
383	(cond ((pair? x) (cons (ac-niltree (car x)) (ac-niltree (cdr x))))		547	(cond ((pair? x) (cons (ac-niltree (car x)) (ac-niltree (cdr x))))
384	((or (eq? x #f) (eq? x '())) 'nil)		548	((or (eq? x #f) (eq? x '())) 'nil)
385	(#t x)))		549	(#t x)))
386			550
		<>	551	; The next two are optimizations, except work for macros.
			552
387	;(define (err msg . args)		553	(define (decompose fns args)
			554	(cond ((null? fns) `((fn vals (car vals)) ,@args))
			555	((null? (cdr fns)) (cons (car fns) args))
			556	(#t (list (car fns) (decompose (cdr fns) args)))))
388	; (display msg)		557
			558	(define (ac-andf s env)
389	; (map (lambda (a) (display " ") (write a)) args)		559	(ac (let ((gs (map (lambda (x) (ar-gensym)) (cdr s))))
			560	`((fn ,gs
			561	(and ,@(map (lambda (f) `(,f ,@gs))
			562	(cdar s))))
			563	,@(cdr s)))
390	; (newline)		564	env))
391	; (xxundefined))		565
392			566	(define err error)
393	(define err error) ; eli says need to remove xxundefined for speed
394		=	567
395	; run-time primitive procedures		568	; run-time primitive procedures
396			569
397	(define (xdef a b)	<>	570	;(define (xdef a b)
398	(namespace-set-variable-value! (ac-global-name a) b)		571	; (namespace-set-variable-value! (ac-global-name a) b)
399	b)		572	; b)
400		=	573
		-+	574	(define-syntax xdef
			575	(syntax-rules ()
			576	((xxdef a b)
			577	(let ((nm (ac-global-name 'a))
			578	(a b))
			579	(namespace-set-variable-value! nm a)
			580	a))))
			581
401	(define fn-signatures (make-hash-table 'equal))	=	582	(define fn-signatures (make-hash-table 'equal))
402			583
403	; This is a replacement for xdef that stores opeator signatures.		584	; This is a replacement for xdef that stores opeator signatures.
404	; Haven't started using it yet.		585	; Haven't started using it yet.
405			586
406	(define (odef a parms b)		587	(define (odef a parms b)
407	(namespace-set-variable-value! (ac-global-name a) b)		588	(namespace-set-variable-value! (ac-global-name a) b)
408	(hash-table-put! fn-signatures a (list parms))		589	(hash-table-put! fn-signatures a (list parms))
409	b)		590	b)
410			591
411	(xdef 'sig fn-signatures)	<>	592	(xdef sig fn-signatures)
412		=	593
413	; versions of car and cdr for parsing arguments for optional		594	; versions of car and cdr for parsing arguments for optional
414	; parameters, that yield nil for nil. maybe we should use		595	; parameters, that yield nil for nil. maybe we should use
415	; full Arc car and cdr, so we can destructure more things		596	; full Arc car and cdr, so we can destructure more things
416			597
417	(define (ar-xcar x)		598	(define (ar-xcar x)
418	(if (or (eqv? x 'nil) (eqv? x '()))		599	(if (or (eqv? x 'nil) (eqv? x '()))
419	'nil		600	'nil
420	(car x)))		601	(car x)))
421			602
422	(define (ar-xcdr x)		603	(define (ar-xcdr x)
423	(if (or (eqv? x 'nil) (eqv? x '()))		604	(if (or (eqv? x 'nil) (eqv? x '()))
424	'nil		605	'nil
425	(cdr x)))		606	(cdr x)))
426			607
427	; convert #f from a Scheme predicate to NIL.		608	; convert #f from a Scheme predicate to NIL.
428			609
429	(define (ar-nill x)		610	(define (ar-nill x)
430	(if (or (eq? x '()) (eq? x #f))		611	(if (or (eq? x '()) (eq? x #f))
431	'nil		612	'nil
432	x))		613	x))
433			614
434	; definition of falseness for Arc if.		615	; definition of falseness for Arc if.
435	; must include '() since sometimes Arc functions see		616	; must include '() since sometimes Arc functions see
436	; Scheme lists (e.g. . body of a macro).		617	; Scheme lists (e.g. . body of a macro).
437			618
438	(define (ar-false? x)		619	(define (ar-false? x)
439	(or (eq? x 'nil) (eq? x '()) (eq? x #f)))		620	(or (eq? x 'nil) (eq? x '()) (eq? x #f)))
440			621
441	#\|	+-
442	(if (eq? x 'nil) #t
443	(if (eq? x '()) #t
444	(not x)))
445	\|#
446
447	; call a function or perform an array ref, hash ref, &c	=	622	; call a function or perform an array ref, hash ref, &c
448			623
449	; Non-fn donstants in functional position are valuable real estate, so	<>	624	; Non-fn constants in functional position are valuable real estate, so
450	; should figure out the best way to exploit it.		625	; should figure out the best way to exploit it. What could (1 foo) or
			626	; ('a foo) mean? Maybe it should mean currying.
451		=	627
		-+	628	; For now the way to make the default val of a hash table be other than
			629	; nil is to supply the val when doing the lookup. Later may also let
			630	; defaults be supplied as an arg to table. To implement this, need: an
			631	; eq table within scheme mapping tables to defaults, and to adapt the
			632	; code in arc.arc that reads and writes tables to read and write their
			633	; default vals with them. To make compatible with existing written tables,
			634	; just use an atom or 3-elt list to keep the default.
			635
452	(define (ar-apply fn args)	=	636	(define (ar-apply fn args)
453	(cond ((procedure? fn) (apply fn args))	<>	637	(cond ((procedure? fn)
			638	(apply fn args))
			639	((pair? fn)
454	((pair? fn) (list-ref fn (car args)))		640	(list-ref fn (car args)))
			641	((string? fn)
455	((string? fn) (string-ref fn (car args)))		642	(string-ref fn (car args)))
			643	((hash-table? fn)
456	((hash-table? fn) (ar-nill (hash-table-get fn (car args) #f)))		644	(ar-nill (hash-table-get fn
			645	(car args)
			646	(if (pair? (cdr args)) (cadr args) #f))))
457	; experiment: means e.g. [1] is a constant fn	=	647	; experiment: means e.g. [1] is a constant fn
458	; ((or (number? fn) (symbol? fn)) fn)		648	; ((or (number? fn) (symbol? fn)) fn)
459	; another possibility: constant in functional pos means it gets		649	; another possibility: constant in functional pos means it gets
460	; passed to the first arg, i.e. ('kids item) means (item 'kids).		650	; passed to the first arg, i.e. ('kids item) means (item 'kids).
461	(#t (err "Function call on inappropriate object" fn args))))		651	(#t (err "Function call on inappropriate object" fn args))))
462			652
463	(xdef 'apply (lambda (fn . args)	<>	653	(xdef apply (lambda (fn . args)
464	(ar-apply fn (ar-apply-args args))))	=	654	(ar-apply fn (ar-apply-args args))))
465			655
466	; special cases of ar-apply for speed and to avoid consing arg lists		656	; special cases of ar-apply for speed and to avoid consing arg lists
		-+	657
467	(define (ar-funcall0 fn)	=	658	(define (ar-funcall0 fn)
468	(if (procedure? fn)		659	(if (procedure? fn)
469	(fn)		660	(fn)
470	(ar-apply fn (list))))		661	(ar-apply fn (list))))
471			662
472	(define (ar-funcall1 fn arg1)		663	(define (ar-funcall1 fn arg1)
473	(if (procedure? fn)		664	(if (procedure? fn)
474	(fn arg1)		665	(fn arg1)
475	(ar-apply fn (list arg1))))		666	(ar-apply fn (list arg1))))
476			667
477	(define (ar-funcall2 fn arg1 arg2)		668	(define (ar-funcall2 fn arg1 arg2)
478	(if (procedure? fn)		669	(if (procedure? fn)
479	(fn arg1 arg2)		670	(fn arg1 arg2)
480	(ar-apply fn (list arg1 arg2))))		671	(ar-apply fn (list arg1 arg2))))
481			672
482	(define (ar-funcall3 fn arg1 arg2 arg3)		673	(define (ar-funcall3 fn arg1 arg2 arg3)
483	(if (procedure? fn)		674	(if (procedure? fn)
484	(fn arg1 arg2 arg3)		675	(fn arg1 arg2 arg3)
485	(ar-apply fn (list arg1 arg2 arg3))))		676	(ar-apply fn (list arg1 arg2 arg3))))
486			677
487	(define (ar-funcall4 fn arg1 arg2 arg3 arg4)		678	(define (ar-funcall4 fn arg1 arg2 arg3 arg4)
488	(if (procedure? fn)		679	(if (procedure? fn)
489	(fn arg1 arg2 arg3 arg4)		680	(fn arg1 arg2 arg3 arg4)
490	(ar-apply fn (list arg1 arg2 arg3 arg4))))		681	(ar-apply fn (list arg1 arg2 arg3 arg4))))
491			682
492	; replace the nil at the end of a list with a '()		683	; replace the nil at the end of a list with a '()
493			684
494	(define (ar-nil-terminate l)		685	(define (ar-nil-terminate l)
495	(if (or (eqv? l '()) (eqv? l 'nil))		686	(if (or (eqv? l '()) (eqv? l 'nil))
496	'()		687	'()
497	(cons (car l) (ar-nil-terminate (cdr l)))))		688	(cons (car l) (ar-nil-terminate (cdr l)))))
498			689
499	; turn the arguments to Arc apply into a list.		690	; turn the arguments to Arc apply into a list.
500	; if you call (apply fn 1 2 '(3 4))		691	; if you call (apply fn 1 2 '(3 4))
501	; then args is '(1 2 (3 4 . nil) . ())		692	; then args is '(1 2 (3 4 . nil) . ())
502	; that is, the main list is a scheme list.		693	; that is, the main list is a scheme list.
503	; and we should return '(1 2 3 4 . ())		694	; and we should return '(1 2 3 4 . ())
504	; was once (apply apply list (ac-denil args))		695	; was once (apply apply list (ac-denil args))
505	; but that didn't work for (apply fn nil)		696	; but that didn't work for (apply fn nil)
506			697
507	(define (ar-apply-args args)		698	(define (ar-apply-args args)
508	(cond ((null? args) '())		699	(cond ((null? args) '())
509	((null? (cdr args)) (ar-nil-terminate (car args)))		700	((null? (cdr args)) (ar-nil-terminate (car args)))
510	(#t (cons (car args) (ar-apply-args (cdr args))))))		701	(#t (cons (car args) (ar-apply-args (cdr args))))))
511			702
		<>	703
			704
			705
			706
512	(xdef 'cons cons)		707	(xdef cons cons)
513		=	708
514	(xdef 'car (lambda (x)	<>	709	(xdef car (lambda (x)
515	(cond ((pair? x) (car x))	=	710	(cond ((pair? x) (car x))
516	((eqv? x 'nil) 'nil)		711	((eqv? x 'nil) 'nil)
517	((eqv? x '()) 'nil)		712	((eqv? x '()) 'nil)
518	(#t (err "Can't take car of" x)))))		713	(#t (err "Can't take car of" x)))))
519			714
520	(xdef 'cdr (lambda (x)	<>	715	(xdef cdr (lambda (x)
521	(cond ((pair? x) (cdr x))	=	716	(cond ((pair? x) (cdr x))
522	((eqv? x 'nil) 'nil)		717	((eqv? x 'nil) 'nil)
523	((eqv? x '()) 'nil)		718	((eqv? x '()) 'nil)
524	(#t (err "Can't take cdr of" x)))))		719	(#t (err "Can't take cdr of" x)))))
525			720
		-+	721	(define (tnil x) (if x 't 'nil))
			722
			723	; (pairwise pred '(a b c d)) =>
			724	; (and (pred a b) (pred b c) (pred c d))
			725	; pred returns t/nil, as does pairwise
526	; reduce?	=	726	; reduce?
527			727
528	(define (pairwise pred args base)	<>	728	(define (pairwise pred lst)
529	(let ((n (length args)))
530	(cond ((< n 2) base)		729	(cond ((null? lst) 't)
531	((= n 2) (apply pred args))		730	((null? (cdr lst)) 't)
532	(#t (and (pred (car args) (cadr args))		731	((not (eqv? (pred (car lst) (cadr lst)) 'nil))
533	(pairwise pred (cdr args) base))))))		732	(pairwise pred (cdr lst)))
			733	(#t 'nil)))
534		=	734
535	; not quite right, because behavior of underlying eqv unspecified		735	; not quite right, because behavior of underlying eqv unspecified
536	; in many cases according to r5rs		736	; in many cases according to r5rs
537	; do we really want is to ret t for distinct strings?		737	; do we really want is to ret t for distinct strings?
538			738
539	(xdef 'is (lambda args	<>	739	; for (is x y)
540	(if (or (all (lambda (a) (eqv? (car args) a)) (cdr args))		740
			741	(define (ar-is2 a b)
			742	(tnil (or (eqv? a b)
541	(and (all string? args)		743	(and (string? a) (string? b) (string=? a b))
542	(apply string=? args))
543	(all ar-false? args))		744	(and (ar-false? a) (ar-false? b)))))
544	't 'nil)))		745
			746	; for all other uses of is
545		=	747
		<>	748	(xdef is (lambda args (pairwise ar-is2 args)))
			749
546	(xdef 'err err)		750	(xdef err err)
547	(xdef 'nil 'nil)		751	(xdef nil 'nil)
548	(xdef 't 't)		752	(xdef t 't)
549		=	753
550	(define (all test seq)		754	(define (all test seq)
551	(or (null? seq)		755	(or (null? seq)
552	(and (test (car seq)) (all test (cdr seq)))))		756	(and (test (car seq)) (all test (cdr seq)))))
553			757
554	; rather strictly excludes ()	<>
555
556	(define (arc-list? x) (or (pair? x) (eqv? x 'nil)))		758	(define (arc-list? x) (or (pair? x) (eqv? x 'nil) (eqv? x '())))
557		=	759
558	; generic +: strings, lists, numbers.	<>	760	; Generic +: strings, lists, numbers.
559	; problem with generic +: what to return when no args?
560	; could even coerce based on type of first arg...		761	; Return val has same type as first argument.
561		=	762
562	(xdef '+ (lambda args	<>	763	(xdef + (lambda args
563	(cond ((null? args) 0)	=	764	(cond ((null? args) 0)
564	((all string? args)	<>	765	((char-or-string? (car args))
565	(apply string-append args))		766	(apply string-append
			767	(map (lambda (a) (ar-coerce a 'string))
			768	args)))
566	((all arc-list? args)		769	((arc-list? (car args))
567	(ac-niltree (apply append (map ar-nil-terminate args))))	=	770	(ac-niltree (apply append (map ar-nil-terminate args))))
568	(#t (apply + args)))))		771	(#t (apply + args)))))
569			772
		<>	773	(define (char-or-string? x) (or (string? x) (char? x)))
			774
			775	(define (ar-+2 x y)
			776	(cond ((char-or-string? x)
			777	(string-append (ar-coerce x 'string) (ar-coerce y 'string)))
			778	((and (arc-list? x) (arc-list? y))
			779	(ac-niltree (append (ar-nil-terminate x) (ar-nil-terminate y))))
			780	(#t (+ x y))))
			781
570	(xdef '- -)		782	(xdef - -)
571	(xdef '* *)		783	(xdef * *)
572	(xdef '/ /)		784	(xdef / /)
573	(xdef 'mod modulo)		785	(xdef mod modulo)
574	(xdef 'expt expt)		786	(xdef expt expt)
575	(xdef 'sqrt sqrt)		787	(xdef sqrt sqrt)
576		=	788
577	; generic comparison		789	; generic comparison
578			790
579	(define (arc> . args)	<>	791	(define (ar->2 x y)
580	(cond ((all number? args) (apply > args))		792	(tnil (cond ((and (number? x) (number? y)) (> x y))
581	((all string? args) (pairwise string>? args #f))		793	((and (string? x) (string? y)) (string>? x y))
582	((all symbol? args) (pairwise (lambda (x y)
583	(string>? (symbol->string x)		794	((and (symbol? x) (symbol? y)) (string>? (symbol->string x)
584	(symbol->string y)))		795	(symbol->string y)))
585	args		796	((and (char? x) (char? y)) (char>? x y))
586	#f))		797	(#t (> x y)))))
587	((all char? args) (pairwise char>? args #f))		798
588	(#t (apply > args))))
589	(xdef '> (lambda args (if (apply arc> args) 't 'nil)))		799	(xdef > (lambda args (pairwise ar->2 args)))
590		=	800
591	(define (arc< . args)	<>	801	(define (ar-<2 x y)
592	(cond ((all number? args) (apply < args))		802	(tnil (cond ((and (number? x) (number? y)) (< x y))
593	((all string? args) (pairwise string<? args #f))		803	((and (string? x) (string? y)) (string<? x y))
594	((all symbol? args) (pairwise (lambda (x y)
595	(string<? (symbol->string x)		804	((and (symbol? x) (symbol? y)) (string<? (symbol->string x)
596	(symbol->string y)))		805	(symbol->string y)))
597	args		806	((and (char? x) (char? y)) (char<? x y))
598	#f))		807	(#t (< x y)))))
599	((all char? args) (pairwise char<? args #f))		808
600	(#t (apply < args))))
601	(xdef '< (lambda args (if (apply arc< args) 't 'nil)))		809	(xdef < (lambda args (pairwise ar-<2 args)))
602		=	810
603	(xdef 'len (lambda (x)	<>	811	(xdef len (lambda (x)
604	(cond ((string? x) (string-length x))	=	812	(cond ((string? x) (string-length x))
605	((hash-table? x) (hash-table-count x))		813	((hash-table? x) (hash-table-count x))
606	(#t (length (ar-nil-terminate x))))))		814	(#t (length (ar-nil-terminate x))))))
607			815
608	(define (ar-tagged? x)		816	(define (ar-tagged? x)
609	(and (vector? x) (eq? (vector-ref x 0) 'tagged)))		817	(and (vector? x) (eq? (vector-ref x 0) 'tagged)))
610			818
611	(define (ar-tag type rep)		819	(define (ar-tag type rep)
612	(cond ((eqv? (ar-type rep) type) rep)		820	(cond ((eqv? (ar-type rep) type) rep)
613	(#t (vector 'tagged type rep))))		821	(#t (vector 'tagged type rep))))
		<>	822
614	(xdef 'annotate ar-tag)		823	(xdef annotate ar-tag)
615		=	824
616	; (type nil) -> sym		825	; (type nil) -> sym
		-+	826
			827	(define (exint? x) (and (integer? x) (exact? x)))
617		=	828
618	(define (ar-type x)		829	(define (ar-type x)
619	(cond ((ar-tagged? x) (vector-ref x 1))		830	(cond ((ar-tagged? x) (vector-ref x 1))
620	((pair? x) 'cons)		831	((pair? x) 'cons)
621	((symbol? x) 'sym)		832	((symbol? x) 'sym)
622	((null? x) 'sym)		833	((null? x) 'sym)
623	((procedure? x) 'fn)		834	((procedure? x) 'fn)
624	((char? x) 'char)		835	((char? x) 'char)
625	((string? x) 'string)		836	((string? x) 'string)
626	((integer? x) 'int)	<>	837	((exint? x) 'int)
627	((number? x) 'num) ; unsure about this	=	838	((number? x) 'num) ; unsure about this
628	((hash-table? x) 'table)		839	((hash-table? x) 'table)
629	((output-port? x) 'output)		840	((output-port? x) 'output)
630	((input-port? x) 'input)		841	((input-port? x) 'input)
631	((tcp-listener? x) 'socket)		842	((tcp-listener? x) 'socket)
632	((exn? x) 'exception)		843	((exn? x) 'exception)
		-+	844	((thread? x) 'thread)
633	(#t (err "Type: unknown type" x))))	=	845	(#t (err "Type: unknown type" x))))
634	(xdef 'type ar-type)	<>	846	(xdef type ar-type)
635		=	847
636	(define (ar-rep x)		848	(define (ar-rep x)
637	(if (ar-tagged? x)		849	(if (ar-tagged? x)
638	(vector-ref x 2)		850	(vector-ref x 2)
639	x))		851	x))
		<>	852
640	(xdef 'rep ar-rep)		853	(xdef rep ar-rep)
641		=	854
642	; currently rather a joke: returns interned symbols		855	; currently rather a joke: returns interned symbols
643			856
644	(define ar-gensym-count 0)		857	(define ar-gensym-count 0)
		-+	858
645	(define (ar-gensym)	=	859	(define (ar-gensym)
646	(set! ar-gensym-count (+ ar-gensym-count 1))		860	(set! ar-gensym-count (+ ar-gensym-count 1))
647	(string->symbol (string-append "gs" (number->string ar-gensym-count))))		861	(string->symbol (string-append "gs" (number->string ar-gensym-count))))
		<>	862
648	(xdef 'uniq ar-gensym)		863	(xdef uniq ar-gensym)
649		=	864
650	(xdef 'ccc call-with-current-continuation)	<>	865	(xdef ccc call-with-current-continuation)
651		=	866
652	(xdef 'infile open-input-file)	<>	867	(xdef infile open-input-file)
			868
653	(xdef 'outfile (lambda (f . args)		869	(xdef outfile (lambda (f . args)
654	(open-output-file f	=	870	(open-output-file f
655	'text		871	'text
656	(if (equal? args '(append))		872	(if (equal? args '(append))
657	'append		873	'append
658	'truncate))))		874	'truncate))))
659			875
660	(xdef 'instring open-input-string)	<>	876	(xdef instring open-input-string)
661	(xdef 'outstring open-output-string)		877	(xdef outstring open-output-string)
662		=	878
663	; use as general fn for looking inside things		879	; use as general fn for looking inside things
664			880
665	(xdef 'inside get-output-string)	<>	881	(xdef inside get-output-string)
666		=	882
667	(xdef 'close (lambda (p)	<>
668	(cond ((input-port? p) (close-input-port p))
669	((output-port? p) (close-output-port p))
670	((tcp-listener? p) (tcp-close p))
671	(#t (err "Can't close " p)))
672	'nil))
673
674	(xdef 'stdout current-output-port) ; should be a vars		883	(xdef stdout current-output-port) ; should be a vars
675	(xdef 'stdin current-input-port)		884	(xdef stdin current-input-port)
676	(xdef 'stderr current-error-port)		885	(xdef stderr current-error-port)
677		=	886
678	(xdef 'call-w/stdout	<>	887	(xdef call-w/stdout
679	(lambda (port thunk)	=	888	(lambda (port thunk)
680	(parameterize ((current-output-port port)) (thunk))))		889	(parameterize ((current-output-port port)) (thunk))))
681			890
682	(xdef 'call-w/stdin	<>	891	(xdef call-w/stdin
683	(lambda (port thunk)	=	892	(lambda (port thunk)
684	(parameterize ((current-input-port port)) (thunk))))		893	(parameterize ((current-input-port port)) (thunk))))
685			894
686	; (readc stream)	<>
687	; nil stream means stdout
688	; returns nil on eof
689
690	(xdef 'readc (lambda (str)		895	(xdef readc (lambda str
691	(let ((p (if (ar-false? str)		896	(let ((c (read-char (if (pair? str)
			897	(car str)
692	(current-input-port)		898	(current-input-port)))))
693	str)))
694	(let ((c (read-char p)))
695	(if (eof-object? c) 'nil c)))))		899	(if (eof-object? c) 'nil c))))
696		=	900
		<>	901
697	(xdef 'readb (lambda (str)		902	(xdef readb (lambda str
698	(let ((p (if (ar-false? str)		903	(let ((c (read-byte (if (pair? str)
			904	(car str)
699	(current-input-port)		905	(current-input-port)))))
700	str)))
701	(let ((c (read-byte p)))
702	(if (eof-object? c) 'nil c)))))		906	(if (eof-object? c) 'nil c))))
703		=	907
704	(xdef 'peekc (lambda (str)	<>	908	(xdef peekc (lambda str
705	(let ((p (if (ar-false? str)		909	(let ((c (peek-char (if (pair? str)
			910	(car str)
706	(current-input-port)		911	(current-input-port)))))
707	str)))
708	(let ((c (peek-char p)))
709	(if (eof-object? c) 'nil c)))))		912	(if (eof-object? c) 'nil c))))
710		=	913
711	(xdef 'writec (lambda (c . args)	<>	914	(xdef writec (lambda (c . args)
712	(write-char c	=	915	(write-char c
713	(if (pair? args)		916	(if (pair? args)
714	(car args)		917	(car args)
715	(current-output-port)))		918	(current-output-port)))
716	c))		919	c))
717			920
718	(xdef 'writeb (lambda (b . args)	<>	921	(xdef writeb (lambda (b . args)
719	(write-byte b	=	922	(write-byte b
720	(if (pair? args)		923	(if (pair? args)
721	(car args)		924	(car args)
722	(current-output-port)))		925	(current-output-port)))
723	b))		926	b))
724			927
		<>	928	(define explicit-flush #f)
725	(xdef 'write (lambda args		929
726	(if (pair? args)		930	(define (printwith f args)
727	(write (ac-denil (car args))		931	(let ((port (if (> (length args) 1)
728	(if (pair? (cdr args))
729	(cadr args)		932	(cadr args)
730	(current-output-port))))		933	(current-output-port))))
731	(flush-output)
732	'nil))
733
734	(xdef 'disp (lambda args
735	(if (pair? args)		934	(when (pair? args)
736	(display (ac-denil (car args))		935	(f (ac-denil (car args)) port))
737	(if (pair? (cdr args))
738	(cadr args)
739	(current-output-port))))		936	(unless explicit-flush (flush-output port)))
740	(flush-output)
741	'nil))		937	'nil)
742		=	938
		-+	939	(xdef write (lambda args (printwith write args)))
			940	(xdef disp (lambda args (printwith display args)))
			941
743	; sread = scheme read. eventually replace by writing read	=	942	; sread = scheme read. eventually replace by writing read
744			943
745	(xdef 'sread (lambda (p eof)	<>	944	(xdef sread (lambda (p eof)
746	(let ((expr (read p)))	=	945	(let ((expr (read p)))
747	(if (eof-object? expr) eof expr))))		946	(if (eof-object? expr) eof expr))))
748			947
749	; these work in PLT but not scheme48		948	; these work in PLT but not scheme48
750			949
751	(define char->ascii char->integer)		950	(define char->ascii char->integer)
752	(define ascii->char integer->char)		951	(define ascii->char integer->char)
753			952
		<>	953	(define (iround x) (inexact->exact (round x)))
			954
754	(xdef 'coerce (lambda (x type . args)		955	(define (ar-coerce x type . args)
755	(cond		956	(cond
756	((ar-tagged? x) (err "Can't coerce annotated object"))		957	((ar-tagged? x) (err "Can't coerce annotated object"))
757	((eqv? type (ar-type x)) x)		958	((eqv? type (ar-type x)) x)
758
759	((char? x) (case type		959	((char? x) (case type
760	((int) (char->ascii x))		960	((int) (char->ascii x))
761	((string) (string x))		961	((string) (string x))
762	((sym) (string->symbol (string x)))		962	((sym) (string->symbol (string x)))
763	(else (err "Can't coerce" x type))))		963	(else (err "Can't coerce" x type))))
764	((integer? x) (case type		964	((exint? x) (case type
			965	((num) x)
765	((char) (ascii->char x))		966	((char) (ascii->char x))
766	((string) (apply number->string x args))		967	((string) (apply number->string x args))
767	(else (err "Can't coerce" x type))))		968	(else (err "Can't coerce" x type))))
768	((number? x) (case type		969	((number? x) (case type
769	((int) (round x))		970	((int) (iround x))
770	((char) (ascii->char (round x)))		971	((char) (ascii->char (iround x)))
771	((string) (apply number->string x args))		972	((string) (apply number->string x args))
772	(else (err "Can't coerce" x type))))		973	(else (err "Can't coerce" x type))))
773	((string? x) (case type		974	((string? x) (case type
774	((sym) (string->symbol x))		975	((sym) (string->symbol x))
775	((cons) (ac-niltree (string->list x)))		976	((cons) (ac-niltree (string->list x)))
776	((int) (or (apply string->number x args)		977	((num) (or (apply string->number x args)
777	(err "Can't coerce" x type)))		978	(err "Can't coerce" x type)))
			979	((int) (let ((n (apply string->number x args)))
			980	(if n
			981	(iround n)
			982	(err "Can't coerce" x type))))
778	(else (err "Can't coerce" x type))))		983	(else (err "Can't coerce" x type))))
779	((pair? x) (case type		984	((pair? x) (case type
780	((string) (list->string		985	((string) (apply string-append
			986	(map (lambda (y) (ar-coerce y 'string))
781	(ar-nil-terminate x)))		987	(ar-nil-terminate x))))
782	(else (err "Can't coerce" x type))))		988	(else (err "Can't coerce" x type))))
783	((eqv? x 'nil) (case type		989	((eqv? x 'nil) (case type
784	((string) "")		990	((string) "")
785	(else (err "Can't coerce" x type))))		991	(else (err "Can't coerce" x type))))
			992	((null? x) (case type
			993	((string) "")
			994	(else (err "Can't coerce" x type))))
786	((symbol? x) (case type		995	((symbol? x) (case type
787	((string) (symbol->string x))		996	((string) (symbol->string x))
788	(else (err "Can't coerce" x type))))		997	(else (err "Can't coerce" x type))))
789	(#t x))))		998	(#t x)))
790		=	999
		<>	1000	(xdef coerce ar-coerce)
			1001
791	(xdef 'open-socket (lambda (num) (tcp-listen num 50 #t)))		1002	(xdef open-socket (lambda (num) (tcp-listen num 50 #t)))
792		=	1003
793	; the 2050 means http requests currently capped at 2 meg		1004	; the 2050 means http requests currently capped at 2 meg
794	; http://list.cs.brown.edu/pipermail/plt-scheme/2005-August/009414.html		1005	; http://list.cs.brown.edu/pipermail/plt-scheme/2005-August/009414.html
795			1006
796	(xdef 'socket-accept (lambda (s)	<>	1007	(xdef socket-accept (lambda (s)
			1008	(let ((oc (current-custodian))
			1009	(nc (make-custodian)))
			1010	(current-custodian nc)
797	(call-with-values		1011	(call-with-values
798	(lambda () (tcp-accept s))	=	1012	(lambda () (tcp-accept s))
799	(lambda (in out)		1013	(lambda (in out)
800	(list (make-limited-input-port in 100000 #t)	<>	1014	(let ((in1 (make-limited-input-port in 100000 #t)))
			1015	(current-custodian oc)
			1016	(associate-custodian nc in1 out)
			1017	(list in1
801	out		1018	out
802	(let-values (((us them) (tcp-addresses out)))		1019	(let-values (((us them) (tcp-addresses out)))
803	them))))))		1020	them))))))))
804		=	1021
		<>	1022	; allow Arc to give up root privileges after it
			1023	; calls open-socket. thanks, Eli!
			1024	(define setuid (get-ffi-obj 'setuid #f (_fun _int -> _int)))
			1025	(xdef setuid setuid)
			1026
805	(xdef 'thread thread)		1027	(xdef new-thread thread)
806	(xdef 'kill-thread kill-thread)		1028	(xdef kill-thread kill-thread)
807	(xdef 'break-thread break-thread)		1029	(xdef break-thread break-thread)
			1030	(xdef current-thread current-thread)
808		=	1031
809	(define (wrapnil f) (lambda args (apply f args) 'nil))		1032	(define (wrapnil f) (lambda args (apply f args) 'nil))
810			1033
811	(xdef 'sleep (wrapnil sleep))	<>	1034	(xdef sleep (wrapnil sleep))
812		=	1035
813	; Will system "execute" a half-finished string if thread killed		1036	; Will system "execute" a half-finished string if thread killed
814	; in the middle of generating it?		1037	; in the middle of generating it?
815			1038
816	(xdef 'system (wrapnil system))	<>	1039	(xdef system (wrapnil system))
817		=	1040
818	(xdef 'pipe-from (lambda (cmd)	<>	1041	(xdef pipe-from (lambda (cmd)
819	(let ((tf (ar-tmpname)))	=	1042	(let ((tf (ar-tmpname)))
820	(system (string-append cmd " > " tf))		1043	(system (string-append cmd " > " tf))
821	(let ((str (open-input-file tf)))		1044	(let ((str (open-input-file tf)))
822	(system (string-append "rm -f " tf))		1045	(system (string-append "rm -f " tf))
823	str))))		1046	str))))
824			1047
825	(define (ar-tmpname)		1048	(define (ar-tmpname)
826	(call-with-input-file "/dev/urandom"		1049	(call-with-input-file "/dev/urandom"
827	(lambda (rstr)		1050	(lambda (rstr)
828	(do ((s "/tmp/")		1051	(do ((s "/tmp/")
829	(c (read-char rstr) (read-char rstr))		1052	(c (read-char rstr) (read-char rstr))
830	(i 0 (+ i 1)))		1053	(i 0 (+ i 1)))
831	((>= i 16) s)		1054	((>= i 16) s)
832	(set! s (string-append s		1055	(set! s (string-append s
833	(string		1056	(string
834	(integer->char		1057	(integer->char
835	(+ (char->integer #\a)		1058	(+ (char->integer #\a)
836	(modulo		1059	(modulo
837	(char->integer (read-char rstr))		1060	(char->integer (read-char rstr))
838	26))))))))))		1061	26))))))))))
839			1062
840	; PLT scheme provides only eq? and equal? hash tables,		1063	; PLT scheme provides only eq? and equal? hash tables,
841	; we need the latter for strings.		1064	; we need the latter for strings.
842			1065
		<>	1066	(xdef table (lambda args
843	(xdef 'table (lambda () (make-hash-table 'equal)))		1067	(let ((h (make-hash-table 'equal)))
			1068	(if (pair? args) ((car args) h))
			1069	h)))
844		=	1070
845	;(xdef 'table (lambda args	<>	1071	;(xdef table (lambda args
846	; (fill-table (make-hash-table 'equal)	=	1072	; (fill-table (make-hash-table 'equal)
847	; (if (pair? args) (ac-denil (car args)) '()))))		1073	; (if (pair? args) (ac-denil (car args)) '()))))
848			1074
849	(define (fill-table h pairs)		1075	(define (fill-table h pairs)
850	(if (eq? pairs '())		1076	(if (eq? pairs '())
851	h		1077	h
852	(let ((pair (car pairs)))		1078	(let ((pair (car pairs)))
853	(begin (hash-table-put! h (car pair) (cadr pair))		1079	(begin (hash-table-put! h (car pair) (cadr pair))
854	(fill-table h (cdr pairs))))))		1080	(fill-table h (cdr pairs))))))
855			1081
856	(xdef 'maptable (lambda (fn table) ; arg is (fn (key value) ...)	<>	1082	(xdef maptable (lambda (fn table) ; arg is (fn (key value) ...)
857	(hash-table-for-each table fn)	=	1083	(hash-table-for-each table fn)
858	table))		1084	table))
859			1085
860	(xdef 'protect (lambda (during after)	<>	1086	(define (protect during after)
861	(dynamic-wind (lambda () #t) during after)))		1087	(dynamic-wind (lambda () #t) during after))
862		=	1088
		-+	1089	(xdef protect protect)
			1090
863	; need to use a better seed	=	1091	; need to use a better seed
864			1092
865	(xdef 'rand random)	<>	1093	(xdef rand random)
866		=	1094
		<>	1095	(xdef dir (lambda (name)
867	(xdef 'dir (lambda (name) (map path->string (directory-list name))))		1096	(ac-niltree (map path->string (directory-list name)))))
868		=	1097
		<>	1098	; Would def mkdir in terms of make-directory and call that instead
			1099	; of system in ensure-dir, but make-directory is too weak: it doesn't
			1100	; create intermediate directories like mkdir -p.
			1101
869	(xdef 'file-exists (lambda (name)		1102	(xdef file-exists (lambda (name)
870	(if (file-exists? name) name 'nil)))	=	1103	(if (file-exists? name) name 'nil)))
871			1104
872	(xdef 'dir-exists (lambda (name)	<>	1105	(xdef dir-exists (lambda (name)
873	(if (directory-exists? name) name 'nil)))	=	1106	(if (directory-exists? name) name 'nil)))
874			1107
875	(xdef 'rmfile (wrapnil delete-file))	<>	1108	(xdef rmfile (wrapnil delete-file))
876		=	1109
		-+	1110	(xdef mvfile (lambda (old new)
			1111	(rename-file-or-directory old new #t)
			1112	'nil))
			1113
877	; top level read-eval-print	=	1114	; top level read-eval-print
878	; tle kept as a way to get a break loop when a scheme err		1115	; tle kept as a way to get a break loop when a scheme err
879			1116
880	(define (arc-eval expr)		1117	(define (arc-eval expr)
881	(eval (ac expr '()) (interaction-environment)))	<>	1118	(eval (ac expr '())))
882		=	1119
883	(define (tle)		1120	(define (tle)
884	(display "Arc> ")		1121	(display "Arc> ")
885	(let ((expr (read)))		1122	(let ((expr (read)))
886	(when (not (eqv? expr ':a))		1123	(when (not (eqv? expr ':a))
887	(write (arc-eval expr))		1124	(write (arc-eval expr))
888	(newline)		1125	(newline)
889	(tle))))		1126	(tle))))
890			1127
891	(define last-condition* #f)		1128	(define last-condition* #f)
892			1129
893	(define (tl)		1130	(define (tl)
894	(display "Use (quit) to quit, (tl) to return here after an interrupt.\n")		1131	(display "Use (quit) to quit, (tl) to return here after an interrupt.\n")
895	(tl2))		1132	(tl2))
896			1133
897	(define (tl2)		1134	(define (tl2)
898	(display "arc> ")		1135	(display "arc> ")
899	(on-err (lambda (c)		1136	(on-err (lambda (c)
900	(set! last-condition* c)		1137	(set! last-condition* c)
901	(display "Error: ")		1138	(display "Error: ")
902	(write (exn-message c))		1139	(write (exn-message c))
903	(newline)		1140	(newline)
904	(tl2))		1141	(tl2))
905	(lambda ()		1142	(lambda ()
906	(let ((expr (read)))		1143	(let ((expr (read)))
907	(if (eqv? expr ':a)		1144	(if (eqv? expr ':a)
908	'done		1145	'done
909	(let ((val (arc-eval expr)))		1146	(let ((val (arc-eval expr)))
910	(write (ac-denil val))		1147	(write (ac-denil val))
911	(namespace-set-variable-value! '_that val)		1148	(namespace-set-variable-value! '_that val)
912	(namespace-set-variable-value! '_thatexpr expr)		1149	(namespace-set-variable-value! '_thatexpr expr)
913	(newline)		1150	(newline)
914	(tl2)))))))		1151	(tl2)))))))
915			1152
916	(define (aload1 p)		1153	(define (aload1 p)
917	(let ((x (read p)))		1154	(let ((x (read p)))
918	(if (eof-object? x)		1155	(if (eof-object? x)
919	#t		1156	#t
920	(begin		1157	(begin
921	(arc-eval x)		1158	(arc-eval x)
922	(aload1 p)))))		1159	(aload1 p)))))
923			1160
924	(define (atests1 p)		1161	(define (atests1 p)
925	(let ((x (read p)))		1162	(let ((x (read p)))
926	(if (eof-object? x)		1163	(if (eof-object? x)
927	#t		1164	#t
928	(begin		1165	(begin
929	(write x)		1166	(write x)
930	(newline)		1167	(newline)
931	(let ((v (arc-eval x)))		1168	(let ((v (arc-eval x)))
932	(if (ar-false? v)		1169	(if (ar-false? v)
933	(begin		1170	(begin
934	(display " FAILED")		1171	(display " FAILED")
935	(newline))))		1172	(newline))))
936	(atests1 p)))))		1173	(atests1 p)))))
937			1174
938	(define (aload filename)		1175	(define (aload filename)
939	(call-with-input-file filename aload1))		1176	(call-with-input-file filename aload1))
940			1177
941	(define (test filename)		1178	(define (test filename)
942	(call-with-input-file filename atests1))		1179	(call-with-input-file filename atests1))
943			1180
944	(define (acompile1 ip op)		1181	(define (acompile1 ip op)
945	(let ((x (read ip)))		1182	(let ((x (read ip)))
946	(if (eof-object? x)		1183	(if (eof-object? x)
947	#t		1184	#t
948	(let ((scm (ac x '())))		1185	(let ((scm (ac x '())))
949	(eval scm (interaction-environment))	<>	1186	(eval scm)
950	(pretty-print scm op)	=	1187	(pretty-print scm op)
951	(newline op)		1188	(newline op)
952	(newline op)		1189	(newline op)
953	(acompile1 ip op)))))		1190	(acompile1 ip op)))))
954			1191
955	; compile xx.arc to xx.arc.scm		1192	; compile xx.arc to xx.arc.scm
956	; useful to examine the Arc compiler output		1193	; useful to examine the Arc compiler output
957	(define (acompile inname)		1194	(define (acompile inname)
958	(let ((outname (string-append inname ".scm")))		1195	(let ((outname (string-append inname ".scm")))
959	(if (file-exists? outname)		1196	(if (file-exists? outname)
960	(delete-file outname))		1197	(delete-file outname))
961	(call-with-input-file inname		1198	(call-with-input-file inname
962	(lambda (ip)		1199	(lambda (ip)
963	(call-with-output-file outname		1200	(call-with-output-file outname
964	(lambda (op)		1201	(lambda (op)
965	(acompile1 ip op)))))))		1202	(acompile1 ip op)))))))
966			1203
967	(xdef 'macex (lambda (e) (ac-macex (ac-denil e))))	<>	1204	(xdef macex (lambda (e) (ac-macex (ac-denil e))))
968		=	1205
969	(xdef 'macex1 (lambda (e) (ac-macex (ac-denil e) 'once)))	<>	1206	(xdef macex1 (lambda (e) (ac-macex (ac-denil e) 'once)))
970		=	1207
971	(xdef 'eval (lambda (e)	<>	1208	(xdef eval (lambda (e)
972	(eval (ac (ac-denil e) '()) (interaction-environment))))		1209	(eval (ac (ac-denil e) '()))))
973		=	1210
974	; If an err occurs in an on-err expr, no val is returned and code		1211	; If an err occurs in an on-err expr, no val is returned and code
975	; after it doesn't get executed. Not quite what I had in mind.		1212	; after it doesn't get executed. Not quite what I had in mind.
976			1213
977	(define (on-err errfn f)		1214	(define (on-err errfn f)
978	((call-with-current-continuation		1215	((call-with-current-continuation
979	(lambda (k)		1216	(lambda (k)
980	(lambda ()		1217	(lambda ()
981	(with-handlers ((exn:fail? (lambda (c)		1218	(with-handlers ((exn:fail? (lambda (c)
982	(k (lambda () (errfn c))))))		1219	(k (lambda () (errfn c))))))
983	(f)))))))		1220	(f)))))))
984	(xdef 'on-err on-err)	<>	1221	(xdef on-err on-err)
985		=	1222
986	(define (write-to-string x)	<>	1223	(define (disp-to-string x)
987	(let ((o (open-output-string)))	=	1224	(let ((o (open-output-string)))
988	(write x o)	<>	1225	(display x o)
989	(close-output-port o)	=	1226	(close-output-port o)
990	(get-output-string o)))		1227	(get-output-string o)))
991			1228
992	(xdef 'details (lambda (c)	<>	1229	(xdef details (lambda (c)
993	(write-to-string (exn-message c))))		1230	(disp-to-string (exn-message c))))
994		=	1231
995	(xdef 'scar (lambda (x val)	<>	1232	(xdef scar (lambda (x val)
996	(if (string? x)	=	1233	(if (string? x)
997	(string-set! x 0 val)		1234	(string-set! x 0 val)
998	(set-car! x val))	<>	1235	(x-set-car! x val))
999	val))	=	1236	val))
1000			1237
1001	(xdef 'scdr (lambda (x val)	<>	1238	(xdef scdr (lambda (x val)
1002	(if (string? x)	=	1239	(if (string? x)
1003	(err "Can't set cdr of a string" x)		1240	(err "Can't set cdr of a string" x)
1004	(set-cdr! x val))	<>	1241	(x-set-cdr! x val))
1005	val))	=	1242	val))
		-+	1243
			1244	; decide at run-time whether the underlying mzscheme supports
			1245	; set-car! and set-cdr!, since I can't figure out how to do it
			1246	; at compile time.
			1247
			1248	(define (x-set-car! p v)
			1249	(let ((fn (namespace-variable-value 'set-car! #t (lambda () #f))))
			1250	(if (procedure? fn)
			1251	(fn p v)
			1252	(n-set-car! p v))))
			1253
			1254	(define (x-set-cdr! p v)
			1255	(let ((fn (namespace-variable-value 'set-cdr! #t (lambda () #f))))
			1256	(if (procedure? fn)
			1257	(fn p v)
			1258	(n-set-cdr! p v))))
			1259
			1260	; Eli's code to modify mzscheme-4's immutable pairs.
			1261
			1262	;; to avoid a malloc on every call, reuse a single pointer, but make
			1263	;; it thread-local to avoid races
			1264	(define ptr (make-thread-cell #f))
			1265	(define (get-ptr)
			1266	(or (thread-cell-ref ptr)
			1267	(let ([p (malloc _scheme 1)]) (thread-cell-set! ptr p) p)))
			1268
			1269	;; set a pointer to the cons cell, then dereference it as a pointer,
			1270	;; and bang the new value in the given offset
			1271	(define (set-ca/dr! offset who p x)
			1272	(if (pair? p)
			1273	(let ([p* (get-ptr)])
			1274	(ptr-set! p* _scheme p)
			1275	(ptr-set! (ptr-ref p* _pointer 0) _scheme offset x))
			1276	(raise-type-error who "pair" p)))
			1277
			1278	(define (n-set-car! p x) (set-ca/dr! 1 'set-car! p x))
			1279	(define (n-set-cdr! p x) (set-ca/dr! 2 'set-cdr! p x))
1006		=	1280
1007	; When and if cdr of a string returned an actual (eq) tail, could		1281	; When and if cdr of a string returned an actual (eq) tail, could
1008	; say (if (string? x) (string-replace! x val 1) ...) in scdr, but		1282	; say (if (string? x) (string-replace! x val 1) ...) in scdr, but
1009	; for now would be misleading to allow this, because fails for cddr.		1283	; for now would be misleading to allow this, because fails for cddr.
1010			1284
1011	(define (string-replace! str val index)		1285	(define (string-replace! str val index)
1012	(if (eqv? (string-length val) (- (string-length str) index))		1286	(if (eqv? (string-length val) (- (string-length str) index))
1013	(do ((i index (+ i 1)))		1287	(do ((i index (+ i 1)))
1014	((= i (string-length str)) str)		1288	((= i (string-length str)) str)
1015	(string-set! str i (string-ref val (- i index))))		1289	(string-set! str i (string-ref val (- i index))))
1016	(err "Length mismatch between strings" str val index)))		1290	(err "Length mismatch between strings" str val index)))
1017			1291
		<>	1292	; Later may want to have multiple indices.
1018	(xdef 'sref (lambda (com val ind) ; later make ind rest arg		1293
			1294	(xdef sref
			1295	(lambda (com val ind)
1019	(cond ((hash-table? com) (if (eqv? val 'nil)		1296	(cond ((hash-table? com) (if (eqv? val 'nil)
1020	(hash-table-remove! com ind)		1297	(hash-table-remove! com ind)
1021	(hash-table-put! com ind val)))		1298	(hash-table-put! com ind val)))
1022	((string? com) (string-set! com ind val))		1299	((string? com) (string-set! com ind val))
1023	((pair? com) (nth-set! com ind val))		1300	((pair? com) (nth-set! com ind val))
1024	(#t (err "Can't set reference " com ind val)))		1301	(#t (err "Can't set reference " com ind val)))
1025	val))		1302	val))
1026		=	1303
1027	(define (nth-set! lst n val)		1304	(define (nth-set! lst n val)
1028	(set-car! (list-tail lst n) val))	<>	1305	(x-set-car! (list-tail lst n) val))
1029		=	1306
1030	; rewrite to pass a (true) gensym instead of #f in case var bound to #f		1307	; rewrite to pass a (true) gensym instead of #f in case var bound to #f
1031			1308
1032	(define (bound? arcname)		1309	(define (bound? arcname)
1033	(namespace-variable-value (ac-global-name arcname)		1310	(namespace-variable-value (ac-global-name arcname)
1034	#t		1311	#t
1035	(lambda () #f)))		1312	(lambda () #f)))
1036			1313
1037	(xdef 'bound (lambda (x) (if (bound? x) 't 'nil)))	<>	1314	(xdef bound (lambda (x) (tnil (bound? x))))
1038		=	1315
1039	(xdef 'newstring make-string)	<>	1316	(xdef newstring make-string)
1040		=	1317
1041	(xdef 'truncate (lambda (x) (inexact->exact (truncate x))))	<>	1318	(xdef trunc (lambda (x) (inexact->exact (truncate x))))
1042		=	1319
		<>	1320	; bad name
			1321
1043	(xdef 'exact (lambda (x) (and (integer? x) (exact? x))))		1322	(xdef exact (lambda (x) (tnil (exint? x))))
1044		=	1323
1045	(xdef 'msec current-milliseconds)	<>	1324	(xdef msec current-milliseconds)
1046	(xdef 'current-process-milliseconds current-process-milliseconds)		1325	(xdef current-process-milliseconds current-process-milliseconds)
1047	(xdef 'current-gc-milliseconds current-gc-milliseconds)		1326	(xdef current-gc-milliseconds current-gc-milliseconds)
1048		=	1327
1049	(xdef 'seconds current-seconds)	<>	1328	(xdef seconds current-seconds)
1050		=	1329
1051	(print-hash-table #t)		1330	(print-hash-table #t)
1052			1331
1053	(xdef 'client-ip (lambda (port)	<>	1332	(xdef client-ip (lambda (port)
1054	(let-values (((x y) (tcp-addresses port)))	=	1333	(let-values (((x y) (tcp-addresses port)))
1055	y)))		1334	y)))
1056			1335
1057	; make sure only one thread at a time executes anything		1336	; make sure only one thread at a time executes anything
1058	; inside an atomic-invoke. atomic-invoke is allowed to		1337	; inside an atomic-invoke. atomic-invoke is allowed to
1059	; nest within a thread; the thread-cell keeps track of		1338	; nest within a thread; the thread-cell keeps track of
1060	; whether this thread already holds the lock.		1339	; whether this thread already holds the lock.
1061	; XXX make sure cell is set #f after an exception?	<>	1340
1062	; maybe it doesn't matter since thread will die?
1063	(define ar-the-sema (make-semaphore 1))	=	1341	(define ar-the-sema (make-semaphore 1))
		-+	1342
1064	(define ar-sema-cell (make-thread-cell #f))	=	1343	(define ar-sema-cell (make-thread-cell #f))
		<>	1344
1065	(xdef 'atomic-invoke (lambda (f)		1345	(xdef atomic-invoke (lambda (f)
1066	(if (thread-cell-ref ar-sema-cell)	=	1346	(if (thread-cell-ref ar-sema-cell)
1067	(ar-apply f '())		1347	(ar-apply f '())
1068	(begin		1348	(begin
1069	(thread-cell-set! ar-sema-cell #t)		1349	(thread-cell-set! ar-sema-cell #t)
1070	(let ((ret	<>	1350	(protect
			1351	(lambda ()
1071	(call-with-semaphore		1352	(call-with-semaphore
1072	ar-the-sema		1353	ar-the-sema
1073	(lambda () (ar-apply f '())))))		1354	(lambda () (ar-apply f '()))))
			1355	(lambda ()
1074	(thread-cell-set! ar-sema-cell #f)		1356	(thread-cell-set! ar-sema-cell #f)))))))
1075	ret)))))		1357
1076			1358	(xdef dead (lambda (x) (tnil (thread-dead? x))))
1077	(xdef 'dead thread-dead?)		1359
1078			1360	; Added because Mzscheme buffers output. Not a permanent part of Arc.
1079	; Added because Mzscheme buffers output. Not sure if want as official		1361	; Only need to use when declare explicit-flush optimization.
1080	; part of Arc.
1081		=	1362
1082	;(xdef 'flushout (lambda () (flush-output) 't))	<>	1363	(xdef flushout (lambda () (flush-output) 't))
1083		=	1364
1084	(xdef 'ssyntax (lambda (x) (if (ssyntax? x) 't 'nil)))	<>	1365	(xdef ssyntax (lambda (x) (tnil (ssyntax? x))))
1085		=	1366
1086	(xdef 'ssexpand (lambda (x)	<>	1367	(xdef ssexpand (lambda (x)
1087	(if (symbol? x) (expand-ssyntax x) x)))	=	1368	(if (symbol? x) (expand-ssyntax x) x)))
1088			1369
1089	(xdef 'quit exit)	<>	1370	(xdef quit exit)
1090		=	1371
		-+	1372	; there are two ways to close a TCP output port.
			1373	; (close o) waits for output to drain, then closes UNIX descriptor.
			1374	; (force-close o) discards buffered output, then closes UNIX desc.
			1375	; web servers need the latter to get rid of connections to
			1376	; clients that are not reading data.
			1377	; mzscheme close-output-port doesn't work (just raises an error)
			1378	; if there is buffered output for a non-responsive socket.
			1379	; must use custodian-shutdown-all instead.
1091		=	1380
		-+	1381	(define custodians (make-hash-table 'equal))
			1382
			1383	(define (associate-custodian c i o)
			1384	(hash-table-put! custodians i c)
			1385	(hash-table-put! custodians o c))
			1386
			1387	; if a port has a custodian, use it to close the port forcefully.
			1388	; also get rid of the reference to the custodian.
			1389	; sadly doing this to the input port also kills the output port.
			1390
			1391	(define (try-custodian p)
			1392	(let ((c (hash-table-get custodians p #f)))
			1393	(if c
			1394	(begin
			1395	(custodian-shutdown-all c)
			1396	(hash-table-remove! custodians p)
			1397	#t)
			1398	#f)))
			1399
			1400	(define (ar-close . args)
			1401	(map (lambda (p)
			1402	(cond ((input-port? p) (close-input-port p))
			1403	((output-port? p) (close-output-port p))
			1404	((tcp-listener? p) (tcp-close p))
			1405	(#t (err "Can't close " p))))
			1406	args)
			1407	(map (lambda (p) (try-custodian p)) args) ; free any custodian
			1408	'nil)
			1409
			1410	(xdef close ar-close)
			1411
			1412	(xdef force-close (lambda args
			1413	(map (lambda (p)
			1414	(if (not (try-custodian p))
			1415	(ar-close p)))
			1416	args)
			1417	'nil))
			1418
			1419	(xdef memory current-memory-use)
			1420
			1421	(xdef declare (lambda (key val)
			1422	(let ((flag (not (ar-false? val))))
			1423	(case key
			1424	((atstrings) (set! atstrings flag))
			1425	((direct-calls) (set! direct-calls flag))
			1426	((explicit-flush) (set! explicit-flush flag)))
			1427	val)))
			1428
			1429	(putenv "TZ" ":GMT")
			1430
			1431	(define (gmt-date sec) (seconds->date sec))
			1432
			1433	(xdef timedate
			1434	(lambda args
			1435	(let ((d (gmt-date (if (pair? args) (car args) (current-seconds)))))
			1436	(ac-niltree (list (date-second d)
			1437	(date-minute d)
			1438	(date-hour d)
			1439	(date-day d)
			1440	(date-month d)
			1441	(date-year d))))))
			1442
			1443	(xdef sin sin)
			1444	(xdef cos cos)
			1445	(xdef tan tan)
			1446	(xdef asin asin)
			1447	(xdef acos acos)
			1448	(xdef atan atan)
			1449	(xdef log log)
			1450
			1451	(define (codestring s)
			1452	(let ((i (atpos s 0)))
			1453	(if i
			1454	(cons (substring s 0 i)
			1455	(let* ((rest (substring s (+ i 1)))
			1456	(in (open-input-string rest))
			1457	(expr (read in))
			1458	(i2 (let-values (((x y z) (port-next-location in))) z)))
			1459	(close-input-port in)
			1460	(cons expr (codestring (substring rest (- i2 1))))))
			1461	(list s))))
			1462
			1463	; First unescaped @ in s, if any. Escape by doubling.
			1464
			1465	(define (atpos s i)
			1466	(cond ((eqv? i (string-length s))
			1467	#f)
			1468	((eqv? (string-ref s i) #\@)
			1469	(if (and (< (+ i 1) (string-length s))
			1470	(not (eqv? (string-ref s (+ i 1)) #\@)))
			1471	i
			1472	(atpos s (+ i 2))))
			1473	(#t
			1474	(atpos s (+ i 1)))))
			1475
			1476	(define (unescape-ats s)
			1477	(list->string (letrec ((unesc (lambda (cs)
			1478	(cond
			1479	((null? cs)
			1480	'())
			1481	((and (eqv? (car cs) #\@)
			1482	(not (null? (cdr cs)))
			1483	(eqv? (cadr cs) #\@))
			1484	(unesc (cdr cs)))
			1485	(#t
			1486	(cons (car cs) (unesc (cdr cs))))))))
			1487	(unesc (string->list s)))))
			1488
1092	)	=	1489	)
1093			1490
1094	(require ac)	+-
1095		=	1491
1096	./app.arc		1492	./app.arc
1097	; Application Server. Layer inserted 2 Sep 06.		1493	; Application Server. Layer inserted 2 Sep 06.
1098			1494
		<>	1495	; ideas:
1099	; todo: def a general notion of apps of which the programming app is		1496	; def a general notion of apps of which prompt is one, news another
1100	; one and the news site another.
1101	; give each user a place to store data? A home dir?	=	1497	; give each user a place to store data? A home dir?
1102			1498
1103	; A user is simply a string: "pg". Use /whoami to test user cookie.		1499	; A user is simply a string: "pg". Use /whoami to test user cookie.
1104			1500
1105	(= hpwfile* "arc/hpw"		1501	(= hpwfile* "arc/hpw"
		-+	1502	oidfile* "arc/openids"
1106	adminfile* "arc/admins"	=	1503	adminfile* "arc/admins"
1107	cookfile* "arc/cooks")		1504	cookfile* "arc/cooks")
1108			1505
1109	(def asv ((o port 8080))		1506	(def asv ((o port 8080))
1110	(load-userinfo)		1507	(load-userinfo)
1111	(serve port))		1508	(serve port))
1112			1509
1113	(def load-userinfo ()		1510	(def load-userinfo ()
1114	(= hpasswords* (safe-load-table hpwfile*)		1511	(= hpasswords* (safe-load-table hpwfile*)
		-+	1512	openids* (safe-load-table oidfile*)
1115	admins* (map string (errsafe (readfile adminfile*)))	=	1513	admins* (map string (errsafe (readfile adminfile*)))
1116	cookie->user* (safe-load-table cookfile*))		1514	cookie->user* (safe-load-table cookfile*))
1117	(maptable (fn (k v) (= (user->cookie* v) k))		1515	(maptable (fn (k v) (= (user->cookie* v) k))
1118	cookie->user*))		1516	cookie->user*))
1119			1517
1120	; idea: a bidirectional table, so don't need two vars (and sets)		1518	; idea: a bidirectional table, so don't need two vars (and sets)
1121			1519
1122	(= cookie->user* (table) user->cookie* (table) logins* (table))		1520	(= cookie->user* (table) user->cookie* (table) logins* (table))
1123			1521
1124	(def get-user (req)		1522	(def get-user (req)
1125	(let u (aand (alref (req 'cooks) "user") (cookie->user* (sym it)))	<>	1523	(let u (aand (alref req!cooks "user") (cookie->user* (sym it)))
1126	(when u (= (logins* u) (req 'ip)))		1524	(when u (= (logins* u) req!ip))
1127	u))	=	1525	u))
1128			1526
1129	(mac when-usermatch (user req . body)	<>	1527	(mac when-umatch (user req . body)
1130	`(if (is ,user (get-user ,req))	=	1528	`(if (is ,user (get-user ,req))
1131	(do ,@body)		1529	(do ,@body)
1132	(mismatch-message)))		1530	(mismatch-message)))
1133			1531
		<>	1532	(def mismatch-message ()
1134	(def mismatch-message () (prn "Dead link: users don't match."))		1533	(prn "Dead link: users don't match."))
1135		=	1534
1136	(mac when-usermatchr (user req . body)	<>	1535	(mac when-umatch/r (user req . body)
1137	`(if (is ,user (get-user ,req))	=	1536	`(if (is ,user (get-user ,req))
1138	(do ,@body)		1537	(do ,@body)
1139	"mismatch"))		1538	"mismatch"))
1140			1539
1141	(defop mismatch req (mismatch-message))		1540	(defop mismatch req (mismatch-message))
1142			1541
1143	(mac matchform (user req after . body)	<>	1542	(mac uform (user req after . body)
1144	`(aform (fn (,req)	=	1543	`(aform (fn (,req)
1145	(when-usermatch ,user ,req	<>	1544	(when-umatch ,user ,req
1146	,after))	=	1545	,after))
1147	,@body))		1546	,@body))
1148			1547
1149	(mac matchrform (user req after . body)	<>	1548	(mac urform (user req after . body)
1150	`(arform (fn (,req)	=	1549	`(arform (fn (,req)
1151	(when-usermatchr ,user ,req	<>	1550	(when-umatch/r ,user ,req
1152	,after))	=	1551	,after))
1153	,@body))		1552	,@body))
1154			1553
1155	; Like onlink, but checks that user submitting the request is the		1554	; Like onlink, but checks that user submitting the request is the
1156	; same it was generated for. Really should log the username and	<>	1555	; same it was generated for. For extra protection could log the
1157	; ip addr of every genlink, and check if they match.		1556	; username and ip addr of every genlink, and check if they match.
1158		=	1557
1159	(mac userlink (user text . body)	<>	1558	(mac ulink (user text . body)
1160	(w/uniq req	=	1559	(w/uniq req
1161	`(linkf ,text (,req)		1560	`(linkf ,text (,req)
1162	(when-usermatch ,user ,req ,@body))))	<>	1561	(when-umatch ,user ,req ,@body))))
1163		=	1562
1164			1563
1165	(defop admin req (admin-gate (get-user req)))		1564	(defop admin req (admin-gate (get-user req)))
1166			1565
1167	(def admin-gate (u)		1566	(def admin-gate (u)
1168	(if (admin u)		1567	(if (admin u)
1169	(admin-page u)		1568	(admin-page u)
1170	(login-page 'login nil		1569	(login-page 'login nil
1171	(fn (u ip) (admin-gate u)))))		1570	(fn (u ip) (admin-gate u)))))
1172			1571
1173	(def admin (u) (and u (mem u admins*)))		1572	(def admin (u) (and u (mem u admins*)))
1174			1573
1175	(def user-exists (u) (and u (hpasswords* u) u))		1574	(def user-exists (u) (and u (hpasswords* u) u))
1176			1575
1177	(def admin-page (user . msg)		1576	(def admin-page (user . msg)
1178	(whitepage		1577	(whitepage
1179	(prbold "Admin: ")		1578	(prbold "Admin: ")
1180	(hspace 20)		1579	(hspace 20)
1181	(pr user " \| ")		1580	(pr user " \| ")
1182	(w/link (do (logout-user user)		1581	(w/link (do (logout-user user)
1183	(whitepage (pr "Bye " user ".")))		1582	(whitepage (pr "Bye " user ".")))
1184	(pr "logout"))		1583	(pr "logout"))
1185	(when msg (hspace 10) (map pr msg))		1584	(when msg (hspace 10) (map pr msg))
1186	(br2)		1585	(br2)
1187	(aform (fn (req)		1586	(aform (fn (req)
1188	(when-usermatch user req	<>	1587	(when-umatch user req
1189	(with (u (arg req "u") p (arg req "p"))	=	1588	(with (u (arg req "u") p (arg req "p"))
1190	(if (or (no u) (no p) (is u "") (is p ""))		1589	(if (or (no u) (no p) (is u "") (is p ""))
1191	(pr "Bad data.")		1590	(pr "Bad data.")
1192	(user-exists u)		1591	(user-exists u)
1193	(admin-page user "User already exists: " u)		1592	(admin-page user "User already exists: " u)
1194	(do (create-acct u p)		1593	(do (create-acct u p)
1195	(admin-page user))))))		1594	(admin-page user))))))
1196	(pwfields "create (server) account"))))		1595	(pwfields "create (server) account"))))
1197		+-
1198	; need to define a notion of a hashtable that's always written
1199	; to a file when modified
1200		=	1596
1201	(def cook-user (user)		1597	(def cook-user (user)
1202	(let id (new-user-cookie)		1598	(let id (new-user-cookie)
1203	(= (cookie->user* id) user		1599	(= (cookie->user* id) user
1204	(user->cookie* user) id)		1600	(user->cookie* user) id)
1205	(save-table cookie->user* cookfile*)		1601	(save-table cookie->user* cookfile*)
1206	id))		1602	id))
1207			1603
1208	; Unique-ids are only unique per server invocation.		1604	; Unique-ids are only unique per server invocation.
1209			1605
1210	(def new-user-cookie ()		1606	(def new-user-cookie ()
1211	(let id (unique-id)		1607	(let id (unique-id)
1212	(if (cookie->user* id) (new-user-cookie) id)))		1608	(if (cookie->user* id) (new-user-cookie) id)))
1213			1609
1214	(def logout-user (user)		1610	(def logout-user (user)
1215	(nil! (logins* user))	<>	1611	(wipe (logins* user))
1216	(nil! (cookie->user* (user->cookie* user)) (user->cookie* user))		1612	(wipe (cookie->user* (user->cookie* user)) (user->cookie* user))
1217	(save-table cookie->user* cookfile*))	=	1613	(save-table cookie->user* cookfile*))
1218			1614
1219	(def create-acct (user pw)		1615	(def create-acct (user pw)
		-+	1616	(set (dc-usernames* (downcase user)))
1220	(set-pw user pw))	=	1617	(set-pw user pw))
1221			1618
1222	(def disable-acct (user)		1619	(def disable-acct (user)
1223	(set-pw user (rand-string 20))		1620	(set-pw user (rand-string 20))
1224	(logout-user user))		1621	(logout-user user))
1225			1622
1226	(def set-pw (user pw)		1623	(def set-pw (user pw)
1227	(= (hpasswords* user) (and pw (shash pw)))		1624	(= (hpasswords* user) (and pw (shash pw)))
1228	(save-table hpasswords* hpwfile*))		1625	(save-table hpasswords* hpwfile*))
1229			1626
1230	(def hello-page (user ip)		1627	(def hello-page (user ip)
1231	(whitepage (prs "hello" user "at" ip)))		1628	(whitepage (prs "hello" user "at" ip)))
1232			1629
1233	(defop login req (login-page 'login))		1630	(defop login req (login-page 'login))
1234			1631
1235	; switch is one of: register, login, both		1632	; switch is one of: register, login, both
		<>	1633
1236	; afterward is a function on the newly created user, ip addr		1634	; afterward is either a function on the newly created username and
			1635	; ip address, in which case it is called to generate the next page
1237	; or can be a list of such a fn and a string, in which case call fn		1636	; after a successful login, or a pair of (function url), which means
1238	; then redirect to string		1637	; call the function, then redirect to the url.
1239		=	1638
1240	; classic example of something that should just "return" a val		1639	; classic example of something that should just "return" a val
1241	; via a continuation rather than going to a new page.		1640	; via a continuation rather than going to a new page.
1242			1641
1243	; ugly code-- too much duplication	+-
1244
1245	(def login-page (switch (o msg nil) (o afterward hello-page))	=	1642	(def login-page (switch (o msg nil) (o afterward hello-page))
1246	(whitepage		1643	(whitepage
1247	(pagemessage msg)		1644	(pagemessage msg)
1248	(when (in switch 'login 'both)		1645	(when (in switch 'login 'both)
1249	(prbold "Login")	<>
1250	(br2)
1251	(if (acons afterward)
1252	(let (f url) afterward
1253	(arformh (fn (req)
1254	(logout-user (get-user req))
1255	(aif (good-login (arg req "u") (arg req "p") (req 'ip))
1256	(do (= (logins* it) (req 'ip))
1257	(prcookie (user->cookie* it))
1258	(f it (req 'ip))
1259	url)
1260	(flink (fn ignore (login-page switch		1646	(login-form "Login" switch login-handler afterward)
1261	"Bad login."
1262	afterward)))))
1263	(pwfields)))
1264	(aformh (fn (req)		1647	(hook 'login-form afterward)
1265	(logout-user (get-user req))
1266	(aif (good-login (arg req "u") (arg req "p") (req 'ip))
1267	(do (= (logins* it) (req 'ip))
1268	(prcookie (user->cookie* it))
1269	(prn)
1270	(afterward it (req 'ip)))
1271	(do (prn)
1272	(login-page switch "Bad login." afterward))))
1273	(pwfields)))
1274	(br2))	=	1648	(br2))
1275	(when (in switch 'register 'both)		1649	(when (in switch 'register 'both)
		<>	1650	(login-form "Create Account" switch create-handler afterward))))
1276	(prbold "Create Account")		1651
			1652	(def login-form (label switch handler afterward)
			1653	(prbold label)
1277	(br2)		1654	(br2)
			1655	(fnform (fn (req) (handler req switch afterward))
			1656	(fn () (pwfields (downcase label)))
1278	(if (acons afterward)		1657	(acons afterward)))
			1658
1279	(let (f url) afterward		1659	(def login-handler (req switch afterward)
			1660	(logout-user (get-user req))
			1661	(aif (good-login (arg req "u") (arg req "p") req!ip)
			1662	(login it req!ip (user->cookie* it) afterward)
			1663	(failed-login switch "Bad login." afterward)))
1280	(arformh (fn (req)		1664
			1665	(def create-handler (req switch afterward)
1281	(logout-user (get-user req))		1666	(logout-user (get-user req))
1282	(with (user (arg req "u") pw (arg req "p"))		1667	(with (user (arg req "u") pw (arg req "p"))
1283	(aif (bad-newacct user pw)		1668	(aif (bad-newacct user pw)
1284	(flink (fn ignore
1285	(login-page switch it afterward)))		1669	(failed-login switch it afterward)
1286	(do (create-acct user pw)		1670	(do (create-acct user pw)
			1671	(login user req!ip (cook-user user) afterward)))))
			1672
			1673	(def login (user ip cookie afterward)
1287	(= (logins* user) (req 'ip))		1674	(= (logins* user) ip)
1288	(prcookie (cook-user user))		1675	(prcookie cookie)
			1676	(if (acons afterward)
			1677	(let (f url) afterward
1289	(f user (req 'ip))		1678	(f user ip)
1290	url))))		1679	url)
1291	(pwfields "create account")))
1292	(aformh (fn (req)
1293	(logout-user (get-user req))
1294	(with (user (arg req "u") pw (arg req "p"))
1295	(aif (bad-newacct user pw)
1296	(do (prn)		1680	(do (prn)
			1681	(afterward user ip))))
			1682
1297	(login-page switch it afterward))		1683	(def failed-login (switch msg afterward)
1298	(do (create-acct user pw)		1684	(if (acons afterward)
1299	(= (logins* user) (req 'ip))		1685	(flink (fn ignore (login-page switch msg afterward)))
1300	(prcookie (cook-user user))
1301	(prn)		1686	(do (prn)
1302	(afterward user (req 'ip))))))
1303	(pwfields "create account"))))))		1687	(login-page switch msg afterward))))
1304			1688
1305	(def prcookie (cook)	=	1689	(def prcookie (cook)
1306	(prn "Set-Cookie: user=" cook "; expires=Sun, 17-Jan-2038 19:14:07 GMT"))		1690	(prn "Set-Cookie: user=" cook "; expires=Sun, 17-Jan-2038 19:14:07 GMT"))
1307			1691
1308	(def pwfields ((o label "login"))		1692	(def pwfields ((o label "login"))
1309	(inputs u username 20 nil		1693	(inputs u username 20 nil
1310	p password 20 nil)		1694	p password 20 nil)
1311	(br)		1695	(br)
1312	(submit label))		1696	(submit label))
1313			1697
1314	(= good-logins* (queue) bad-logins* (queue))		1698	(= good-logins* (queue) bad-logins* (queue))
1315			1699
1316	(def good-login (user pw ip)		1700	(def good-login (user pw ip)
1317	(let record (list (seconds) ip user pw)	<>	1701	(let record (list (seconds) ip user)
1318	(if (and user pw (aand (shash pw) (is it (hpasswords* user))))	=	1702	(if (and user pw (aand (shash pw) (is it (hpasswords* user))))
1319	(do (unless (user->cookie* user) (cook-user user))		1703	(do (unless (user->cookie* user) (cook-user user))
1320	(enq-limit record good-logins*)		1704	(enq-limit record good-logins*)
1321	user)		1705	user)
1322	(do (enq-limit record bad-logins*)		1706	(do (enq-limit record bad-logins*)
1323	nil))))		1707	nil))))
1324			1708
1325	; can remove this once sha1 installed on pi	+-
1326
1327	; Create a file in case people have quote chars in their pws. I can't	=	1709	; Create a file in case people have quote chars in their pws. I can't
1328	; believe there's no way to just send the chars.		1710	; believe there's no way to just send the chars.
1329			1711
1330	(def shash (str)		1712	(def shash (str)
1331	(let fname (+ "/tmp/shash" (rand-string 10))		1713	(let fname (+ "/tmp/shash" (rand-string 10))
1332	(w/outfile f fname (disp str f))		1714	(w/outfile f fname (disp str f))
1333	(let res (tostring (system (+ "openssl dgst -sha1 <" fname)))		1715	(let res (tostring (system (+ "openssl dgst -sha1 <" fname)))
1334	(do1 (subseq res 0 (- (len res) 1))	<>	1716	(do1 (cut res 0 (- (len res) 1))
1335	(rmfile fname)))))	=	1717	(rmfile fname)))))
1336			1718
		-+	1719	(= dc-usernames* (table))
			1720
			1721	(def username-taken (user)
			1722	(when (empty dc-usernames*)
			1723	(each (k v) hpasswords*
			1724	(set (dc-usernames* (downcase k)))))
			1725	(dc-usernames* (downcase user)))
			1726
1337	(def bad-newacct (user pw)	=	1727	(def bad-newacct (user pw)
1338	(if (no (goodname user 2 15))		1728	(if (no (goodname user 2 15))
1339	"Usernames can only contain letters, digits, dashes and		1729	"Usernames can only contain letters, digits, dashes and
1340	underscores, and should be between 2 and 15 characters long.		1730	underscores, and should be between 2 and 15 characters long.
1341	Please choose another."		1731	Please choose another."
1342	(let dcuser (downcase user)	<>	1732	(username-taken user)
1343	(some [is dcuser (downcase _)] (keys hpasswords*)))
1344	"That username is taken. Please choose another."	=	1733	"That username is taken. Please choose another."
1345	(or (no pw) (< (len pw) 4))		1734	(or (no pw) (< (len pw) 4))
1346	"Passwords should be a least 4 characters long. Please		1735	"Passwords should be a least 4 characters long. Please
1347	choose another."		1736	choose another."
1348	nil))		1737	nil))
1349			1738
1350	(def goodname (str (o min 1) (o max nil))		1739	(def goodname (str (o min 1) (o max nil))
1351	(and (isa str 'string)		1740	(and (isa str 'string)
1352	(>= (len str) min)		1741	(>= (len str) min)
1353	(~find (fn (c) (no (or (alphadig c) (in c #\- #\_))))		1742	(~find (fn (c) (no (or (alphadig c) (in c #\- #\_))))
1354	str)		1743	str)
1355	(isnt (str 0) #\-)		1744	(isnt (str 0) #\-)
1356	(or (no max) (<= (len str) max))		1745	(or (no max) (<= (len str) max))
1357	str))		1746	str))
1358			1747
1359		+-
1360	(defop logout req	=	1748	(defop logout req
1361	(aif (get-user req)		1749	(aif (get-user req)
1362	(do (logout-user it)		1750	(do (logout-user it)
1363	(pr "Logged out."))		1751	(pr "Logged out."))
1364	(pr "You were not logged in.")))		1752	(pr "You were not logged in.")))
1365			1753
1366	(defop whoami req		1754	(defop whoami req
1367	(aif (get-user req)		1755	(aif (get-user req)
1368	(prs it 'at (req 'ip))	<>	1756	(prs it 'at req!ip)
1369	(do (pr "You are not logged in. ")	=	1757	(do (pr "You are not logged in. ")
1370	(w/link (login-page 'both) (pr "Log in"))		1758	(w/link (login-page 'both) (pr "Log in"))
1371	(pr "."))))		1759	(pr "."))))
1372			1760
1373			1761
1374		<>
1375	(= formwid* 60 bigformwid* 80 numwid* 8 formatdoc-url* nil)		1762	(= formwid* 60 bigformwid* 80 numwid* 16 formatdoc-url* nil)
1376		=	1763
1377	; Eventually figure out a way to separate type name from format of		1764	; Eventually figure out a way to separate type name from format of
1378	; input field, instead of having e.g. toks and bigtoks		1765	; input field, instead of having e.g. toks and bigtoks
1379			1766
1380	(def varfield (typ id val)		1767	(def varfield (typ id val)
1381	(if (in typ 'string 'string1 'url)		1768	(if (in typ 'string 'string1 'url)
1382	(gentag input type 'text name id value val size formwid*)		1769	(gentag input type 'text name id value val size formwid*)
1383	(in typ 'num 'int 'posint)	<>	1770	(in typ 'num 'int 'posint 'sym)
1384	(gentag input type 'text name id value val size numwid*)	=	1771	(gentag input type 'text name id value val size numwid*)
1385	(in typ 'users 'toks)		1772	(in typ 'users 'toks)
1386	(gentag input type 'text name id value (tostring (apply prs val))		1773	(gentag input type 'text name id value (tostring (apply prs val))
1387	size formwid*)		1774	size formwid*)
1388	(is typ 'sexpr)		1775	(is typ 'sexpr)
1389	(gentag input type 'text name id		1776	(gentag input type 'text name id
1390	value (tostring (map [do (write _) (sp)] val))		1777	value (tostring (map [do (write _) (sp)] val))
1391	size formwid*)		1778	size formwid*)
1392	(in typ 'syms 'text 'doc 'mdtext 'mdtext2 'lines 'bigtoks)		1779	(in typ 'syms 'text 'doc 'mdtext 'mdtext2 'lines 'bigtoks)
1393	(let text (if (in typ 'syms 'bigtoks)		1780	(let text (if (in typ 'syms 'bigtoks)
1394	(tostring (apply prs val))		1781	(tostring (apply prs val))
		-+	1782	(is typ 'lines)
			1783	(tostring (apply pr (intersperse #\newline val)))
1395	(in typ 'mdtext 'mdtext2)	=	1784	(in typ 'mdtext 'mdtext2)
1396	(unmarkdown val)		1785	(unmarkdown val)
1397	(no val)		1786	(no val)
1398	""		1787	""
1399	val)		1788	val)
1400	(tag (textarea cols (if (is typ 'doc) bigformwid* formwid*)		1789	(tag (textarea cols (if (is typ 'doc) bigformwid* formwid*)
1401	rows (needrows text formwid* 4)		1790	rows (needrows text formwid* 4)
1402	wrap 'virtual		1791	wrap 'virtual
1403	style (if (is typ 'doc) "font-size:8.5pt")		1792	style (if (is typ 'doc) "font-size:8.5pt")
1404	name id)		1793	name id)
1405	(prn) ; needed or 1 initial newline gets chopped off		1794	(prn) ; needed or 1 initial newline gets chopped off
1406	(pr text))		1795	(pr text))
1407	(when (and formatdoc-url* (in typ 'mdtext 'mdtext2))		1796	(when (and formatdoc-url* (in typ 'mdtext 'mdtext2))
1408	(pr " ")		1797	(pr " ")
1409	(tag (font size -2)		1798	(tag (font size -2)
1410	(link "help" formatdoc-url* (gray 175)))))		1799	(link "help" formatdoc-url* (gray 175)))))
1411	(and (acons typ) (is (car typ) 'choice))	<>	1800	(caris typ 'choice)
1412	(menu id (cddr typ) val)	=	1801	(menu id (cddr typ) val)
1413	(is typ 'yesno)		1802	(is typ 'yesno)
1414	(menu id '("yes" "no") (if val "yes" "no"))		1803	(menu id '("yes" "no") (if val "yes" "no"))
1415	(is typ 'hexcol)		1804	(is typ 'hexcol)
1416	(gentag input type 'text name id value val); was (hexrep val)	<>	1805	(gentag input type 'text name id value val)
			1806	(is typ 'time)
			1807	(gentag input type 'text name id value (if val (english-time val) ""))
			1808	(is typ 'date)
			1809	(gentag input type 'text name id value (if val (english-date val) ""))
1417	(err "unknown varfield type" typ)))	=	1810	(err "unknown varfield type" typ)))
1418			1811
1419	(def text-rows (text wid (o pad 3))		1812	(def text-rows (text wid (o pad 3))
1420	(+ (truncate (/ (len text) (* wid .8))) pad))	<>	1813	(+ (trunc (/ (len text) (* wid .8))) pad))
1421		=	1814
1422	(def needrows (text cols (o pad 0))		1815	(def needrows (text cols (o pad 0))
1423	(+ pad (max (+ 1 (count #\newline text))		1816	(+ pad (max (+ 1 (count #\newline text))
1424	(roundup (/ (len text) (- cols 5))))))		1817	(roundup (/ (len text) (- cols 5))))))
1425			1818
1426	(def varline (typ id val)	<>	1819	(def varline (typ id val (o liveurls))
1427	(if (in typ 'users 'syms 'toks 'bigtoks) (apply prs val)	=	1820	(if (in typ 'users 'syms 'toks 'bigtoks) (apply prs val)
1428	(is typ 'lines) (map prn val)		1821	(is typ 'lines) (map prn val)
1429	(is typ 'yesno) (pr (if val 'yes 'no))		1822	(is typ 'yesno) (pr (if val 'yes 'no))
1430	(is typ 'choice) (varline (cadr typ) nil val)	<>	1823	(caris typ 'choice) (varline (cadr typ) nil val)
			1824	(is typ 'url) (if (and liveurls (valid-url val))
			1825	(link val val)
			1826	(pr val))
1431	(text-type typ) (pr (or val ""))	=	1827	(text-type typ) (pr (or val ""))
1432	(pr val)))		1828	(pr val)))
1433			1829
1434	(def text-type (typ) (in typ 'string 'string1 'url 'text 'mdtext 'mdtext2))		1830	(def text-type (typ) (in typ 'string 'string1 'url 'text 'mdtext 'mdtext2))
1435			1831
1436	; Newlines in forms come back as /r/n. Only want the /ns. Currently		1832	; Newlines in forms come back as /r/n. Only want the /ns. Currently
1437	; remove the /rs in individual cases below. Could do it in aform or		1833	; remove the /rs in individual cases below. Could do it in aform or
1438	; even in the parsing of http requests, in the server.		1834	; even in the parsing of http requests, in the server.
1439			1835
1440	; Need the calls to striptags so that news users can't get html		1836	; Need the calls to striptags so that news users can't get html
1441	; into a title or comment by editing it. If want a form that		1837	; into a title or comment by editing it. If want a form that
1442	; can take html, just create another typ for it.		1838	; can take html, just create another typ for it.
1443			1839
1444	(def readvar (typ str (o fail nil))		1840	(def readvar (typ str (o fail nil))
1445	(case (carif typ)		1841	(case (carif typ)
1446	string (striptags str)		1842	string (striptags str)
1447	string1 (if (is str "") fail (striptags str))	<>	1843	string1 (if (blank str) fail (striptags str))
1448	url (if (is str "") str (valid-url str) (striptags str) fail)		1844	url (if (blank str) "" (valid-url str) (clean-url str) fail)
1449	num (let n (saferead str) (if (number n) n fail))	=	1845	num (let n (saferead str) (if (number n) n fail))
1450	int (let n (saferead str)		1846	int (let n (saferead str)
1451	(if (number n) (round n) fail))		1847	(if (number n) (round n) fail))
1452	posint (let n (saferead str)		1848	posint (let n (saferead str)
1453	(if (and (number n) (> n 0)) (round n) fail))		1849	(if (and (number n) (> n 0)) (round n) fail))
1454	text (striptags str)		1850	text (striptags str)
1455	doc (striptags str)		1851	doc (striptags str)
1456	mdtext (md-from-form str)		1852	mdtext (md-from-form str)
1457	mdtext2 (md-from-form str t) ; for md with no links		1853	mdtext2 (md-from-form str t) ; for md with no links
1458	; sym (aif (tokens str) (sym (car it)) fail)	<>	1854	sym (or (sym:car:tokens str) fail)
1459	; syms (map sym (tokens str))		1855	syms (map sym (tokens str))
1460	sexpr (errsafe (readall str))	=	1856	sexpr (errsafe (readall str))
1461	users (rem [no (goodname _)] (tokens str))		1857	users (rem [no (goodname _)] (tokens str))
1462	toks (tokens str)		1858	toks (tokens str)
1463	bigtoks (tokens str)		1859	bigtoks (tokens str)
1464	; lines (or (splitlines (= sss str)) fail)	<>	1860	lines (lines str)
1465	choice (readvar (cadr typ) str)	=	1861	choice (readvar (cadr typ) str)
1466	yesno (is str "yes")		1862	yesno (is str "yes")
1467	hexcol (if (hex>color str) str fail) ; was (or (hex>color str) fail)	<>	1863	hexcol (if (hex>color str) str fail)
			1864	time (or (errsafe (parse-time str)) fail)
			1865	date (or (errsafe (parse-date str)) fail)
1468	(err "unknown readvar type" typ)))	=	1866	(err "unknown readvar type" typ)))
1469			1867
		<>	1868	; dates should be tagged date, and just redefine <
1470	(def splitlines (str)		1869
			1870	(def varcompare (typ)
			1871	(if (in typ 'syms 'sexpr 'users 'toks 'bigtoks 'lines 'hexcol)
			1872	(fn (x y) (> (len x) (len y)))
			1873	(is typ 'date)
			1874	(fn (x y)
			1875	(or (no y) (and x (date< x y))))
			1876	(fn (x y)
			1877	(or (empty y) (and (~empty x) (< x y))))))
1471	(map [rem #\return _] (split (cons #\newline "") str)))		1878
1472		=	1879
1473	(= fail* (uniq))	<>	1880	; (= fail* (uniq))
			1881
			1882	(def fail* ()) ; coudn't possibly come back from a form
1474		=	1883
1475	; Takes a list of fields of the form (type label value view modify) and		1884	; Takes a list of fields of the form (type label value view modify) and
1476	; a fn f and generates a form such that when submitted (f label newval)		1885	; a fn f and generates a form such that when submitted (f label newval)
1477	; will be called for each valid value. Finally done is called.		1886	; will be called for each valid value. Finally done is called.
1478			1887
1479	(def vars-form (user fields f done (o button "update") (o lasts))		1888	(def vars-form (user fields f done (o button "update") (o lasts))
1480	(timed-aform lasts	<>	1889	(taform lasts
			1890	(if (all [no (_ 4)] fields)
			1891	(fn (req))
1481	(fn (req)		1892	(fn (req)
1482	(when-usermatch user req		1893	(when-umatch user req
1483	(each (k v) (req 'args)		1894	(each (k v) req!args
1484	(let name (sym k)		1895	(let name (sym k)
1485	(awhen (find [is (cadr _) name] fields)		1896	(awhen (find [is (cadr _) name] fields)
			1897	; added sho to fix bug
1486	(let (typ id val mod) it		1898	(let (typ id val sho mod) it
1487	(when (and mod v)		1899	(when (and mod v)
1488	(let newval (readvar typ v fail*)		1900	(let newval (readvar typ v fail*)
1489	(unless (is newval fail*)		1901	(unless (is newval fail*)
1490	(f name newval))))))))		1902	(f name newval))))))))
1491	(done)))		1903	(done))))
1492	(tab	=	1904	(tab
1493	(showvars fields))		1905	(showvars fields))
1494	(unless (all [no (_ 4)] fields) ; no modifiable fields		1906	(unless (all [no (_ 4)] fields) ; no modifiable fields
1495	(br)		1907	(br)
1496	(submit button))))		1908	(submit button))))
1497			1909
1498	(def showvars (fields)	<>	1910	(def showvars (fields (o liveurls))
1499	(each (typ id val view mod question) fields	=	1911	(each (typ id val view mod question) fields
1500	(when view		1912	(when view
1501	(when question		1913	(when question
1502	(tr (td (prn question))))		1914	(tr (td (prn question))))
1503	(tr (unless question (tag (td valign 'top) (pr id ":")))		1915	(tr (unless question (tag (td valign 'top) (pr id ":")))
		<>	1916	(td (if mod
			1917	(varfield typ id val)
1504	(td ((if mod varfield varline) typ id val)))		1918	(varline typ id val liveurls))))
1505	(prn))))	=	1919	(prn))))
1506			1920
1507	; http://daringfireball.net/projects/markdown/syntax		1921	; http://daringfireball.net/projects/markdown/syntax
1508			1922
1509	(def md-from-form (str (o nolinks))		1923	(def md-from-form (str (o nolinks))
1510	(markdown (trim (rem #\return (esc<>& str)) 'end) 60 nolinks))	<>	1924	(markdown (trim (rem #\return (esc-tags str)) 'end) 60 nolinks))
1511		=	1925
1512	(def markdown (s (o maxurl) (o nolinks))		1926	(def markdown (s (o maxurl) (o nolinks))
1513	(let ital nil		1927	(let ital nil
1514	(tostring		1928	(tostring
1515	(forlen i s		1929	(forlen i s
1516	(iflet (newi spaces) (indented-code s i (if (is i 0) 2 0))		1930	(iflet (newi spaces) (indented-code s i (if (is i 0) 2 0))
1517	(do (pr "<p><pre><code>")		1931	(do (pr "<p><pre><code>")
1518	(let cb (code-block s (- newi spaces 1))		1932	(let cb (code-block s (- newi spaces 1))
1519	(pr cb)		1933	(pr cb)
1520	(= i (+ (- newi spaces 1) (len cb))))		1934	(= i (+ (- newi spaces 1) (len cb))))
1521	(pr "</code></pre>"))		1935	(pr "</code></pre>"))
1522	(iflet newi (parabreak s i (if (is i 0) 1 0))		1936	(iflet newi (parabreak s i (if (is i 0) 1 0))
1523	(do (unless (is i 0) (pr "<p>"))		1937	(do (unless (is i 0) (pr "<p>"))
1524	(= i (- newi 1)))		1938	(= i (- newi 1)))
1525	(and (is (s i) #\*)		1939	(and (is (s i) #\*)
1526	(or ital		1940	(or ital
1527	(atend i s)		1941	(atend i s)
1528	(and (~whitec (s (+ i 1)))		1942	(and (~whitec (s (+ i 1)))
1529	(pos #\* s (+ i 1)))))		1943	(pos #\* s (+ i 1)))))
1530	(do (pr (if ital "</i>" "<i>"))		1944	(do (pr (if ital "</i>" "<i>"))
1531	(= ital (no ital)))		1945	(= ital (no ital)))
1532	(and (no nolinks)		1946	(and (no nolinks)
1533	(t! gotthere)	+-
1534	(or (litmatch "http://" s i)	=	1947	(or (litmatch "http://" s i)
1535	(litmatch "https://" s i)))		1948	(litmatch "https://" s i)))
1536	(withs (n (urlend s i)		1949	(withs (n (urlend s i)
1537	url (subseq s i n))	<>	1950	url (clean-url (cut s i n)))
1538	(tag (a href url rel 'nofollow)	=	1951	(tag (a href url rel 'nofollow)
1539	(pr (if (no maxurl) url (ellipsize url maxurl))))		1952	(pr (if (no maxurl) url (ellipsize url maxurl))))
1540	(= i (- n 1)))		1953	(= i (- n 1)))
1541	(writec (s i))))))))		1954	(writec (s i))))))))
1542			1955
1543	(def indented-code (s i (o newlines 0) (o spaces 0))		1956	(def indented-code (s i (o newlines 0) (o spaces 0))
1544	(let c (s i)		1957	(let c (s i)
1545	(if (nonwhite c)		1958	(if (nonwhite c)
1546	(if (and (> newlines 1) (> spaces 1))		1959	(if (and (> newlines 1) (> spaces 1))
1547	(list i spaces)		1960	(list i spaces)
1548	nil)		1961	nil)
1549	(atend i s)		1962	(atend i s)
1550	nil		1963	nil
1551	(is c #\newline)		1964	(is c #\newline)
1552	(indented-code s (+ i 1) (+ newlines 1) 0)		1965	(indented-code s (+ i 1) (+ newlines 1) 0)
1553	(indented-code s (+ i 1) newlines (+ spaces 1)))))		1966	(indented-code s (+ i 1) newlines (+ spaces 1)))))
1554			1967
		-+	1968	; If i is start a paragraph break, returns index of start of next para.
			1969
1555	(def parabreak (s i (o newlines 0))	=	1970	(def parabreak (s i (o newlines 0))
1556	(let c (s i)		1971	(let c (s i)
1557	(if (or (nonwhite c) (atend i s))		1972	(if (or (nonwhite c) (atend i s))
1558	(if (> newlines 1) i nil)		1973	(if (> newlines 1) i nil)
1559	(parabreak s (+ i 1) (+ newlines (if (is c #\newline) 1 0))))))		1974	(parabreak s (+ i 1) (+ newlines (if (is c #\newline) 1 0))))))
1560		<>	1975
			1976	; Returns the indices of the next paragraph break in s, if any.
1561		=	1977
		-+	1978	(def next-parabreak (s i)
			1979	(unless (atend i s)
			1980	(aif (parabreak s i)
			1981	(list i it)
			1982	(next-parabreak s (+ i 1)))))
			1983
			1984	(def paras (s (o i 0))
			1985	(if (atend i s)
			1986	nil
			1987	(iflet (endthis startnext) (next-parabreak s i)
			1988	(cons (cut s i endthis)
			1989	(paras s startnext))
			1990	(list (trim (cut s i) 'end)))))
			1991
			1992
1562	; Returns the index of the first char not part of the url beginning	=	1993	; Returns the index of the first char not part of the url beginning
1563	; at i, or len of string if url goes all the way to the end.		1994	; at i, or len of string if url goes all the way to the end.
1564			1995
1565	; Note that > immediately after a url (http://foo.com>) will cause		1996	; Note that > immediately after a url (http://foo.com>) will cause
1566	; an odd result, because the > gets escaped to something beginning		1997	; an odd result, because the > gets escaped to something beginning
1567	; with &, which is treated as part of the url. Perhaps the answer		1998	; with &, which is treated as part of the url. Perhaps the answer
1568	; is just to esc<>& after markdown instead of before.	<>	1999	; is just to esc-tags after markdown instead of before.
1569		=	2000
		<>	2001	; Treats a delimiter as part of a url if it is (a) an open delimiter
			2002	; not followed by whitespace or eos, or (b) a close delimiter
			2003	; balancing a previous open delimiter.
			2004
1570	(def urlend (s i)		2005	(def urlend (s i (o indelim))
1571	(let c (s i)	=	2006	(let c (s i)
1572	(if (atend i s)		2007	(if (atend i s)
1573	(if ((orf punc delimc whitec) c) i (+ i 1))	<>	2008	(if ((orf punc whitec opendelim) c)
			2009	i
			2010	(closedelim c)
			2011	(if indelim (+ i 1) i)
			2012	(+ i 1))
1574	(if (or (whitec c)	=	2013	(if (or (whitec c)
		<>	2014	(and (punc c) (whitec (s (+ i 1))))
			2015	(and ((orf whitec punc) (s (+ i 1)))
1575	(delimc c)		2016	(or (opendelim c)
1576	(and (punc c)
1577	((orf whitec delimc) (s (+ i 1)))))		2017	(and (closedelim c) (no indelim)))))
1578	i	=	2018	i
1579	(urlend s (+ i 1))))))	<>	2019	(urlend s (+ i 1) (or (opendelim c)
1580			2020	(and indelim (no (closedelim c)))))))))
1581	(def delimc (c)		2021
1582	(in c #\( #\) #\[ #\] #\{ #\} #\"))		2022	(def opendelim (c) (in c #\< #\( #\[ #\{))
			2023
			2024	(def closedelim (c) (in c #\> #\) #\] #\}))
1583		=	2025
1584			2026
1585	(def code-block (s i)		2027	(def code-block (s i)
1586	(tostring		2028	(tostring
1587	(until (let left (- (len s) i 1)		2029	(until (let left (- (len s) i 1)
1588	(or (is left 0)		2030	(or (is left 0)
1589	(and (> left 2)		2031	(and (> left 2)
1590	(is (s (+ i 1)) #\newline)		2032	(is (s (+ i 1)) #\newline)
1591	(nonwhite (s (+ i 2))))))		2033	(nonwhite (s (+ i 2))))))
1592	(writec (s (++ i))))))		2034	(writec (s (++ i))))))
1593			2035
1594	(def unmarkdown (s)		2036	(def unmarkdown (s)
1595	(tostring		2037	(tostring
1596	(forlen i s		2038	(forlen i s
1597	(if (litmatch "<p>" s i)		2039	(if (litmatch "<p>" s i)
1598	(do (++ i 2)		2040	(do (++ i 2)
1599	(unless (is i 2) (pr "\n\n")))		2041	(unless (is i 2) (pr "\n\n")))
1600	(litmatch "<i>" s i)		2042	(litmatch "<i>" s i)
1601	(do (++ i 2) (pr #\*))		2043	(do (++ i 2) (pr #\*))
1602	(litmatch "</i>" s i)		2044	(litmatch "</i>" s i)
1603	(do (++ i 3) (pr #\*))		2045	(do (++ i 3) (pr #\*))
1604	(litmatch "<a href=" s i)		2046	(litmatch "<a href=" s i)
1605	(let endurl (posmatch [in _ #\> #\space] s (+ i 9))		2047	(let endurl (posmatch [in _ #\> #\space] s (+ i 9))
1606	(if endurl		2048	(if endurl
1607	(do (pr (subseq s (+ i 9) (- endurl 1)))	<>	2049	(do (pr (cut s (+ i 9) (- endurl 1)))
1608	(= i (aif (posmatch "</a>" s endurl)	=	2050	(= i (aif (posmatch "</a>" s endurl)
1609	(+ it 3)		2051	(+ it 3)
1610	endurl)))		2052	endurl)))
1611	(writec (s i))))		2053	(writec (s i))))
1612	(litmatch "<pre><code>" s i)		2054	(litmatch "<pre><code>" s i)
1613	(awhen (findsubseq "</code></pre>" s (+ i 12))		2055	(awhen (findsubseq "</code></pre>" s (+ i 12))
1614	(pr (subseq s (+ i 11) it))	<>	2056	(pr (cut s (+ i 11) it))
1615	(= i (+ it 12)))	=	2057	(= i (+ it 12)))
1616	(litmatch "<pre><code>" s i)	+-
1617	(awhen (findsubseq "</code></pre>" s (+ i 12))
1618	(pr (subseq s (+ i 11) it))
1619	(= i (+ it 12)))
1620	(writec (s i))))))	=	2058	(writec (s i))))))
1621			2059
		-+	2060
			2061	(def english-time (min)
			2062	(let n (mod min 720)
			2063	(string (let h (trunc (/ n 60)) (if (is h 0) "12" h))
			2064	":"
			2065	(let m (mod n 60)
			2066	(if (is m 0) "00"
			2067	(< m 10) (string "0" m)
			2068	m))
			2069	(if (is min 0) " midnight"
			2070	(is min 720) " noon"
			2071	(>= min 720) " pm"
			2072	" am"))))
			2073
			2074	(def parse-time (s)
			2075	(let (nums (o label "")) (halve s letter)
			2076	(with ((h (o m 0)) (map int (tokens nums ~digit))
			2077	cleanlabel (downcase (rem ~alphadig label)))
			2078	(+ (* (if (is h 12)
			2079	(if (in cleanlabel "am" "midnight")
			2080	0
			2081	12)
			2082	(is cleanlabel "am")
			2083	h
			2084	(+ h 12))
			2085	60)
			2086	m))))
			2087
			2088
			2089	(= months* '("January" "February" "March" "April" "May" "June" "July"
			2090	"August" "September" "October" "November" "December"))
			2091
			2092	(def english-date ((y m d))
			2093	(string d " " (months* (- m 1)) " " y))
			2094
			2095	(= month-names* (obj "january" 1 "jan" 1
			2096	"february" 2 "feb" 2
			2097	"march" 3 "mar" 3
			2098	"april" 4 "apr" 4
			2099	"may" 5
			2100	"june" 6 "jun" 6
			2101	"july" 7 "jul" 7
			2102	"august" 8 "aug" 8
			2103	"september" 9 "sept" 9 "sep" 9
			2104	"october" 10 "oct" 10
			2105	"november" 11 "nov" 11
			2106	"december" 12 "dec" 12))
			2107
			2108	(def monthnum (s) (month-names* (downcase s)))
			2109
			2110	; Doesn't work for BC dates.
			2111
			2112	(def parse-date (s)
			2113	(let nums (date-nums s)
			2114	(if (valid-date nums)
			2115	nums
			2116	(err (string "Invalid date: " s)))))
			2117
			2118	(def date-nums (s)
			2119	(with ((ynow mnow dnow) (date)
			2120	toks (tokens s ~alphadig))
			2121	(if (all [all digit _] toks)
			2122	(let nums (map int toks)
			2123	(case (len nums)
			2124	1 (list ynow mnow (car nums))
			2125	2 (iflet d (find [> _ 12] nums)
			2126	(list ynow (find [isnt _ d] nums) d)
			2127	(cons ynow nums))
			2128	(if (> (car nums) 31)
			2129	(firstn 3 nums)
			2130	(rev (firstn 3 nums)))))
			2131	([all digit _] (car toks))
			2132	(withs ((ds ms ys) toks
			2133	d (int ds))
			2134	(aif (monthnum ms)
			2135	(list (or (errsafe (int ys)) ynow)
			2136	it
			2137	d)
			2138	nil))
			2139	(monthnum (car toks))
			2140	(let (ms ds ys) toks
			2141	(aif (errsafe (int ds))
			2142	(list (or (errsafe (int ys)) ynow)
			2143	(monthnum (car toks))
			2144	it)
			2145	nil))
			2146	nil)))
			2147
			2148	; To be correct needs to know days per month, and about leap years
			2149
			2150	(def valid-date ((y m d))
			2151	(and y m d
			2152	(< 0 m 13)
			2153	(< 0 d 32)))
1622		=	2154
1623	(mac defopl (name parm . body)		2155	(mac defopl (name parm . body)
1624	`(defop ,name ,parm		2156	`(defop ,name ,parm
1625	(if (get-user ,parm)		2157	(if (get-user ,parm)
1626	(do ,@body)		2158	(do ,@body)
1627	(login-page 'both		2159	(login-page 'both
1628	"You need to be logged in to do that."		2160	"You need to be logged in to do that."
1629	(list (fn (u ip))		2161	(list (fn (u ip))
1630	(string ',name (reassemble-args ,parm)))))))		2162	(string ',name (reassemble-args ,parm)))))))
1631			2163
1632			2164
1633	./arc.arc		2165	./arc.arc
1634	; Main Arc lib. Ported to Scheme version Jul 06.		2166	; Main Arc lib. Ported to Scheme version Jul 06.
1635			2167
1636	; optimize ~foo in functional position in ac, like compose	<>	2168	; don't like names of conswhen and consif
			2169
1637	; rename: string, into-string (shorter). could call intos string,		2170	; need better way of generating strings; too many calls to string
1638	; but then what to call string?		2171	; maybe strings with escape char for evaluation
			2172	; make foo~bar equiv of foo:~bar (in expand-ssyntax)
			2173	; add sigs of ops defined in ac.scm
1639	; get hold of error types within arc	=	2174	; get hold of error types within arc
1640	; why is macex defined in scheme instead of using def below?	<>	2175	; does macex have to be defined in scheme instead of using def below?
1641	; write disp, read, write in arc	=	2176	; write disp, read, write in arc
1642	; could prob write rmfile and dir in terms of system	<>
1643	; could I get all of macros up into lib.arc?		2177	; could I get all of macros up into arc.arc?
1644			2178	; warn when shadow a global name
1645	; any logical reason I can't say (push x (if foo y z)) ?		2179	; some simple regexp/parsing plan
1646	; eval would have to always ret 2 things, the val and where it came from
1647	; idea: implicit tables of tables; setf empty field, becomes table
1648	; or should setf on a table just take n args?
1649	; idea: permanent objs that live on disk and are updated when modified
1650		=	2180
1651	; compromises in this implementation:		2181	; compromises in this implementation:
1652	; no objs in code		2182	; no objs in code
1653	; (mac testlit args (listtab args)) breaks when called		2183	; (mac testlit args (listtab args)) breaks when called
1654	; separate string type		2184	; separate string type
1655	; (= (cdr (cdr str)) "foo") couldn't work because no way to get str tail		2185	; (= (cdr (cdr str)) "foo") couldn't work because no way to get str tail
		-+	2186	; not sure this is a mistake; strings may be subtly different from
			2187	; lists of chars
1656		=	2188
1657			2189
1658	(set do (annotate 'mac	<>	2190	(assign do (annotate 'mac
1659	(fn args `((fn () ,@args)))))		2191	(fn args `((fn () ,@args)))))
1660		=	2192
1661	(set safeset (annotate 'mac	<>	2193	(assign safeset (annotate 'mac
1662	(fn (var val)		2194	(fn (var val)
1663	`(do (if (bound ',var)		2195	`(do (if (bound ',var)
1664	(do (disp "*** redefining ")		2196	(do (disp "*** redefining " (stderr))
1665	(disp ',var)		2197	(disp ',var (stderr))
1666	(writec #\newline)))		2198	(disp #\newline (stderr))))
1667	(set ,var ,val)))))		2199	(assign ,var ,val)))))
1668		=	2200
1669	(set def (annotate 'mac	<>	2201	(assign def (annotate 'mac
1670	(fn (name parms . body)		2202	(fn (name parms . body)
1671	`(do (sref sig ',parms ',name)		2203	`(do (sref sig ',parms ',name)
1672	(safeset ,name (fn ,parms ,@body))))))		2204	(safeset ,name (fn ,parms ,@body))))))
1673		=	2205
1674	(def caar (xs) (car (car xs)))		2206	(def caar (xs) (car (car xs)))
1675	(def cadr (xs) (car (cdr xs)))		2207	(def cadr (xs) (car (cdr xs)))
1676	(def cddr (xs) (cdr (cdr xs)))		2208	(def cddr (xs) (cdr (cdr xs)))
1677			2209
1678	(def no (x) (is x nil))		2210	(def no (x) (is x nil))
1679			2211
1680	(def acons (x) (is (type x) 'cons))		2212	(def acons (x) (is (type x) 'cons))
1681			2213
1682	(def atom (x) (no (acons x)))		2214	(def atom (x) (no (acons x)))
1683			2215
		<>	2216	; Can return to this def once Rtm gets ac to make all rest args
			2217	; nil-terminated lists.
			2218
1684	(def list args args)		2219	; (def list args args)
1685		=	2220
		-+	2221	(def copylist (xs)
			2222	(if (no xs)
			2223	nil
			2224	(cons (car xs) (copylist (cdr xs)))))
			2225
			2226	(def list args (copylist args))
			2227
1686	(def idfn (x) x)	=	2228	(def idfn (x) x)
1687			2229
1688	; Maybe later make this internal.	<>	2230	; Maybe later make this internal. Useful to let xs be a fn?
1689		=	2231
1690	(def map1 (f xs)		2232	(def map1 (f xs)
1691	(if (no xs)		2233	(if (no xs)
1692	nil		2234	nil
1693	(cons (f (car xs)) (map1 f (cdr xs)))))		2235	(cons (f (car xs)) (map1 f (cdr xs)))))
1694			2236
1695	(def pair (xs (o f list))		2237	(def pair (xs (o f list))
1696	(if (no xs)		2238	(if (no xs)
1697	nil		2239	nil
1698	(no (cdr xs))		2240	(no (cdr xs))
1699	(list (list (car xs)))		2241	(list (list (car xs)))
1700	(cons (f (car xs) (cadr xs))		2242	(cons (f (car xs) (cadr xs))
1701	(pair (cddr xs) f))))		2243	(pair (cddr xs) f))))
1702			2244
1703	(set mac (annotate 'mac	<>	2245	(assign mac (annotate 'mac
1704	(fn (name parms . body)		2246	(fn (name parms . body)
1705	`(do (sref sig ',parms ',name)		2247	`(do (sref sig ',parms ',name)
1706	(safeset ,name (annotate 'mac (fn ,parms ,@body)))))))		2248	(safeset ,name (annotate 'mac (fn ,parms ,@body)))))))
1707		=	2249
1708	(mac and args		2250	(mac and args
1709	(if args		2251	(if args
1710	(if (cdr args)		2252	(if (cdr args)
1711	`(if ,(car args) (and ,@(cdr args)))		2253	`(if ,(car args) (and ,@(cdr args)))
1712	(car args))		2254	(car args))
1713	't))		2255	't))
1714			2256
1715	(def assoc (key al)		2257	(def assoc (key al)
1716	(if (atom al)		2258	(if (atom al)
1717	nil		2259	nil
1718	(and (acons (car al)) (is (caar al) key))		2260	(and (acons (car al)) (is (caar al) key))
1719	(car al)		2261	(car al)
1720	(assoc key (cdr al))))		2262	(assoc key (cdr al))))
1721			2263
1722	(def alref (al key) (cadr (assoc key al)))		2264	(def alref (al key) (cadr (assoc key al)))
1723			2265
1724	(mac with (parms . body)		2266	(mac with (parms . body)
1725	`((fn ,(map1 car (pair parms))		2267	`((fn ,(map1 car (pair parms))
1726	,@body)		2268	,@body)
1727	,@(map1 cadr (pair parms))))		2269	,@(map1 cadr (pair parms))))
1728			2270
1729	(mac let (var val . body)		2271	(mac let (var val . body)
1730	`(with (,var ,val) ,@body))		2272	`(with (,var ,val) ,@body))
1731			2273
1732	(mac withs (parms . body)		2274	(mac withs (parms . body)
1733	(if (no parms)		2275	(if (no parms)
1734	`(do ,@body)		2276	`(do ,@body)
1735	`(let ,(car parms) ,(cadr parms)		2277	`(let ,(car parms) ,(cadr parms)
1736	(withs ,(cddr parms) ,@body))))		2278	(withs ,(cddr parms) ,@body))))
1737			2279
1738	; Rtm prefers to overload + to do this		2280	; Rtm prefers to overload + to do this
1739			2281
1740	(def join args		2282	(def join args
1741	(if (no args)		2283	(if (no args)
1742	nil		2284	nil
1743	(let a (car args)		2285	(let a (car args)
1744	(if (no a)		2286	(if (no a)
1745	(apply join (cdr args))		2287	(apply join (cdr args))
1746	(cons (car a) (apply join (cdr a) (cdr args)))))))		2288	(cons (car a) (apply join (cdr a) (cdr args)))))))
1747			2289
1748	; Need rfn for use in macro expansions.		2290	; Need rfn for use in macro expansions.
1749			2291
1750	(mac rfn (name parms . body)		2292	(mac rfn (name parms . body)
1751	`(let ,name nil		2293	`(let ,name nil
1752	(set ,name (fn ,parms ,@body))))	<>	2294	(assign ,name (fn ,parms ,@body))))
1753		=	2295
1754	(mac afn (parms . body)		2296	(mac afn (parms . body)
1755	`(let self nil		2297	`(let self nil
1756	(set self (fn ,parms ,@body))))	<>	2298	(assign self (fn ,parms ,@body))))
1757		=	2299
1758	; Ac expands x:y:z into (compose x y z), ~x into (complement x)		2300	; Ac expands x:y:z into (compose x y z), ~x into (complement x)
1759			2301
1760	; Only used when the call to compose doesn't occur in functional position.		2302	; Only used when the call to compose doesn't occur in functional position.
1761	; Composes in functional position are transformed away by ac.		2303	; Composes in functional position are transformed away by ac.
1762			2304
1763	(mac compose args		2305	(mac compose args
1764	(let g (uniq)		2306	(let g (uniq)
1765	`(fn ,g		2307	`(fn ,g
1766	,((afn (fs)		2308	,((afn (fs)
1767	(if (cdr fs)		2309	(if (cdr fs)
1768	(list (car fs) (self (cdr fs)))		2310	(list (car fs) (self (cdr fs)))
1769	`(apply ,(if (car fs) (car fs) 'idfn) ,g)))		2311	`(apply ,(if (car fs) (car fs) 'idfn) ,g)))
1770	args))))		2312	args))))
		-+	2313
			2314	; Ditto: complement in functional position optimized by ac.
1771		=	2315
1772	(mac complement (f)		2316	(mac complement (f)
1773	(let g (uniq)		2317	(let g (uniq)
1774	`(fn ,g (no (apply ,f ,g)))))		2318	`(fn ,g (no (apply ,f ,g)))))
1775			2319
1776	(def rev (xs)		2320	(def rev (xs)
1777	((afn (xs acc)		2321	((afn (xs acc)
1778	(if (no xs)		2322	(if (no xs)
1779	acc		2323	acc
1780	(self (cdr xs) (cons (car xs) acc))))		2324	(self (cdr xs) (cons (car xs) acc))))
1781	xs nil))		2325	xs nil))
1782			2326
1783	(def isnt (x y) (no (is x y)))		2327	(def isnt (x y) (no (is x y)))
1784			2328
1785	(mac w/uniq (names . body)		2329	(mac w/uniq (names . body)
1786	(if (acons names)		2330	(if (acons names)
1787	`(with ,(apply + nil (map1 (fn (n) (list n '(uniq)))		2331	`(with ,(apply + nil (map1 (fn (n) (list n '(uniq)))
1788	names))		2332	names))
1789	,@body)		2333	,@body)
1790	`(let ,names (uniq) ,@body)))		2334	`(let ,names (uniq) ,@body)))
1791			2335
1792	(mac or args		2336	(mac or args
1793	(and args		2337	(and args
1794	(w/uniq g		2338	(w/uniq g
1795	`(let ,g ,(car args)		2339	`(let ,g ,(car args)
1796	(if ,g ,g (or ,@(cdr args)))))))		2340	(if ,g ,g (or ,@(cdr args)))))))
1797			2341
1798	(def alist (x) (or (no x) (is (type x) 'cons)))		2342	(def alist (x) (or (no x) (is (type x) 'cons)))
1799			2343
1800	(mac in (x . choices)		2344	(mac in (x . choices)
1801	(w/uniq g		2345	(w/uniq g
1802	`(let ,g ,x		2346	`(let ,g ,x
1803	(or ,@(map1 (fn (c) `(is ,g ,c)) choices)))))		2347	(or ,@(map1 (fn (c) `(is ,g ,c)) choices)))))
1804			2348
1805	; should take n args	<>	2349	; Could take n args, but have never once needed that.
1806		=	2350
1807	(def iso (x y)		2351	(def iso (x y)
1808	(or (is x y)		2352	(or (is x y)
1809	(and (acons x)		2353	(and (acons x)
1810	(acons y)		2354	(acons y)
1811	(iso (car x) (car y))		2355	(iso (car x) (car y))
1812	(iso (cdr x) (cdr y)))))		2356	(iso (cdr x) (cdr y)))))
1813			2357
1814	(mac when (test . body)		2358	(mac when (test . body)
1815	`(if ,test (do ,@body)))		2359	`(if ,test (do ,@body)))
1816			2360
1817	(mac unless (test . body)		2361	(mac unless (test . body)
1818	`(if (no ,test) (do ,@body)))		2362	`(if (no ,test) (do ,@body)))
1819			2363
1820	(mac while (test . body)		2364	(mac while (test . body)
1821	(w/uniq (gf gp)		2365	(w/uniq (gf gp)
1822	`((rfn ,gf (,gp)		2366	`((rfn ,gf (,gp)
1823	(when ,gp ,@body (,gf ,test)))		2367	(when ,gp ,@body (,gf ,test)))
1824	,test)))		2368	,test)))
1825			2369
1826	(def empty (seq)		2370	(def empty (seq)
1827	(or (no seq)		2371	(or (no seq)
1828	(and (no (acons seq)) (is (len seq) 0))))	<>	2372	(and (or (is (type seq) 'string) (is (type seq) 'table))
			2373	(is (len seq) 0))))
1829		=	2374
1830	(def reclist (f xs)		2375	(def reclist (f xs)
1831	(and xs (or (f xs) (reclist f (cdr xs)))))		2376	(and xs (or (f xs) (reclist f (cdr xs)))))
1832			2377
1833	(def recstring (test s (o start 0))		2378	(def recstring (test s (o start 0))
1834	(let n (len s)	<>
1835	((afn (i)		2379	((afn (i)
1836	(and (< i (len s))		2380	(and (< i (len s))
1837	(or (test i)		2381	(or (test i)
1838	(self (+ i 1)))))		2382	(self (+ i 1)))))
1839	start)))		2383	start))
1840		=	2384
1841	(def testify (x)		2385	(def testify (x)
1842	(if (isa x 'fn) x [is _ x]))		2386	(if (isa x 'fn) x [is _ x]))
		-+	2387
			2388	; Like keep, seems like some shouldn't testify. But find should,
			2389	; and all probably should.
1843		=	2390
1844	(def some (test seq)		2391	(def some (test seq)
1845	(let f (testify test)		2392	(let f (testify test)
1846	(if (alist seq)		2393	(if (alist seq)
1847	(reclist f:car seq)		2394	(reclist f:car seq)
1848	(recstring f:seq seq))))		2395	(recstring f:seq seq))))
1849			2396
1850	(def all (test seq)		2397	(def all (test seq)
1851	(~some (complement (testify test)) seq))		2398	(~some (complement (testify test)) seq))
1852			2399
1853	(def mem (test seq)		2400	(def mem (test seq)
1854	(let f (testify test)		2401	(let f (testify test)
1855	(reclist [if (f:car _) _] seq)))		2402	(reclist [if (f:car _) _] seq)))
1856			2403
1857	(def find (test seq)		2404	(def find (test seq)
1858	(let f (testify test)		2405	(let f (testify test)
1859	(if (alist seq)		2406	(if (alist seq)
1860	(reclist [if (f:car _) (car _)] seq)		2407	(reclist [if (f:car _) (car _)] seq)
1861	(recstring [if (f:seq _) (seq _)] seq))))		2408	(recstring [if (f:seq _) (seq _)] seq))))
1862			2409
1863	(def isa (x y) (is (type x) y))		2410	(def isa (x y) (is (type x) y))
1864			2411
1865	; Possible to write map without map1, but makes News 3x slower.		2412	; Possible to write map without map1, but makes News 3x slower.
1866			2413
1867	;(def map (f . seqs)		2414	;(def map (f . seqs)
1868	; (if (some1 no seqs)		2415	; (if (some1 no seqs)
1869	; nil		2416	; nil
1870	; (no (cdr seqs))		2417	; (no (cdr seqs))
1871	; (let s1 (car seqs)		2418	; (let s1 (car seqs)
1872	; (cons (f (car s1))		2419	; (cons (f (car s1))
1873	; (map f (cdr s1))))		2420	; (map f (cdr s1))))
1874	; (cons (apply f (map car seqs))		2421	; (cons (apply f (map car seqs))
1875	; (apply map f (map cdr seqs)))))		2422	; (apply map f (map cdr seqs)))))
1876			2423
1877			2424
1878	(def map (f . seqs)		2425	(def map (f . seqs)
1879	(if (some [isa _ 'string] seqs)		2426	(if (some [isa _ 'string] seqs)
1880	(withs (n (apply min (map len seqs))		2427	(withs (n (apply min (map len seqs))
1881	new (newstring n))		2428	new (newstring n))
1882	((afn (i)		2429	((afn (i)
1883	(if (is i n)		2430	(if (is i n)
1884	new		2431	new
1885	(do (sref new (apply f (map [_ i] seqs)) i)		2432	(do (sref new (apply f (map [_ i] seqs)) i)
1886	(self (+ i 1)))))		2433	(self (+ i 1)))))
1887	0))		2434	0))
1888	(no (cdr seqs))		2435	(no (cdr seqs))
1889	(map1 f (car seqs))		2436	(map1 f (car seqs))
1890	((afn (seqs)		2437	((afn (seqs)
1891	(if (some no seqs)		2438	(if (some no seqs)
1892	nil		2439	nil
1893	(cons (apply f (map1 car seqs))		2440	(cons (apply f (map1 car seqs))
1894	(self (map1 cdr seqs)))))		2441	(self (map1 cdr seqs)))))
1895	seqs)))		2442	seqs)))
1896			2443
1897	(def mappend (f . args)		2444	(def mappend (f . args)
1898	(apply + nil (apply map f args)))		2445	(apply + nil (apply map f args)))
1899			2446
1900	(def firstn (n xs)		2447	(def firstn (n xs)
1901	(if (and (> n 0) xs)	<>	2448	(if (no n) xs
1902	(cons (car xs) (firstn (- n 1) (cdr xs)))		2449	(and (> n 0) xs) (cons (car xs) (firstn (- n 1) (cdr xs)))
1903	nil))		2450	nil))
1904		=	2451
1905	(def nthcdr (n xs)		2452	(def nthcdr (n xs)
1906	(if (> n 0)	<>	2453	(if (no n) xs
1907	(nthcdr (- n 1) (cdr xs))		2454	(> n 0) (nthcdr (- n 1) (cdr xs))
1908	xs))		2455	xs))
1909		=	2456
1910	; Generalization of pair: (tuples x) = (pair x)		2457	; Generalization of pair: (tuples x) = (pair x)
1911			2458
1912	(def tuples (xs (o n 2))		2459	(def tuples (xs (o n 2))
1913	(if (no xs)		2460	(if (no xs)
1914	nil		2461	nil
1915	(cons (firstn n xs)		2462	(cons (firstn n xs)
1916	(tuples (nthcdr n xs) n))))		2463	(tuples (nthcdr n xs) n))))
1917			2464
		<>	2465	; If ok to do with =, why not with def? But see if use it.
			2466
			2467	(mac defs args
			2468	`(do ,@(map [cons 'def _] (tuples args 3))))
			2469
			2470	(def caris (x val)
1918	(def caris (x val) (and (acons x) (is (car x) val)))		2471	(and (acons x) (is (car x) val)))
1919		=	2472
1920	(def warn (msg . args)		2473	(def warn (msg . args)
1921	(disp (+ "Warning: " msg ". "))		2474	(disp (+ "Warning: " msg ". "))
1922	(map [do (write _) (disp " ")] args)		2475	(map [do (write _) (disp " ")] args)
1923	(disp #\newline))		2476	(disp #\newline))
1924			2477
1925	(mac atomic body		2478	(mac atomic body
1926	`(atomic-invoke (fn () ,@body)))		2479	`(atomic-invoke (fn () ,@body)))
1927			2480
1928	(mac atlet args		2481	(mac atlet args
1929	`(atomic (let ,@args)))		2482	`(atomic (let ,@args)))
1930			2483
1931	(mac atwith args		2484	(mac atwith args
1932	`(atomic (with ,@args)))		2485	`(atomic (with ,@args)))
1933			2486
1934	(mac atwiths args		2487	(mac atwiths args
1935	`(atomic (withs ,@args)))		2488	`(atomic (withs ,@args)))
1936			2489
		-+	2490
1937	; setforms returns (vars get set) for a place based on car of an expr	=	2491	; setforms returns (vars get set) for a place based on car of an expr
1938	; vars is a list of gensyms alternating with expressions whose vals they		2492	; vars is a list of gensyms alternating with expressions whose vals they
1939	; should be bound to, suitable for use as first arg to withs		2493	; should be bound to, suitable for use as first arg to withs
1940	; get is an expression returning the current value in the place		2494	; get is an expression returning the current value in the place
1941	; set is an expression representing a function of one argument		2495	; set is an expression representing a function of one argument
1942	; that stores a new value in the place		2496	; that stores a new value in the place
1943			2497
1944	; A bit gross that it works based on the name in the car, but maybe		2498	; A bit gross that it works based on the name in the car, but maybe
1945	; wrong to worry. Macros live in expression land.		2499	; wrong to worry. Macros live in expression land.
1946			2500
1947	; seems meaningful to e.g. (push 1 (pop x)) if (car x) is a cons.		2501	; seems meaningful to e.g. (push 1 (pop x)) if (car x) is a cons.
1948	; can't in cl though. could I define a setter for push or pop?		2502	; can't in cl though. could I define a setter for push or pop?
1949			2503
1950	(set setter (table))	<>	2504	(assign setter (table))
1951		=	2505
1952	(mac defset (name parms . body)		2506	(mac defset (name parms . body)
1953	(w/uniq gexpr		2507	(w/uniq gexpr
1954	`(sref setter		2508	`(sref setter
1955	(fn (,gexpr)		2509	(fn (,gexpr)
1956	(let ,parms (cdr ,gexpr)		2510	(let ,parms (cdr ,gexpr)
1957	,@body))		2511	,@body))
1958	',name)))		2512	',name)))
1959			2513
1960	(defset car (x)		2514	(defset car (x)
1961	(w/uniq g		2515	(w/uniq g
1962	(list (list g x)		2516	(list (list g x)
1963	`(car ,g)		2517	`(car ,g)
1964	`(fn (val) (scar ,g val)))))		2518	`(fn (val) (scar ,g val)))))
1965			2519
1966	(defset cdr (x)		2520	(defset cdr (x)
1967	(w/uniq g		2521	(w/uniq g
1968	(list (list g x)		2522	(list (list g x)
1969	`(cdr ,g)		2523	`(cdr ,g)
1970	`(fn (val) (scdr ,g val)))))		2524	`(fn (val) (scdr ,g val)))))
1971			2525
1972	(defset caar (x)		2526	(defset caar (x)
1973	(w/uniq g		2527	(w/uniq g
1974	(list (list g x)		2528	(list (list g x)
1975	`(caar ,g)		2529	`(caar ,g)
1976	`(fn (val) (scar (car ,g) val)))))		2530	`(fn (val) (scar (car ,g) val)))))
1977			2531
1978	(defset cadr (x)		2532	(defset cadr (x)
1979	(w/uniq g		2533	(w/uniq g
1980	(list (list g x)		2534	(list (list g x)
1981	`(cadr ,g)		2535	`(cadr ,g)
1982	`(fn (val) (scar (cdr ,g) val)))))		2536	`(fn (val) (scar (cdr ,g) val)))))
1983			2537
1984	(defset cddr (x)		2538	(defset cddr (x)
1985	(w/uniq g		2539	(w/uniq g
1986	(list (list g x)		2540	(list (list g x)
1987	`(cddr ,g)		2541	`(cddr ,g)
1988	`(fn (val) (scdr (cdr ,g) val)))))		2542	`(fn (val) (scdr (cdr ,g) val)))))
1989			2543
1990	; Note: if expr0 macroexpands into any expression whose car doesn't		2544	; Note: if expr0 macroexpands into any expression whose car doesn't
1991	; have a setter, setforms assumes it's a data structure in functional		2545	; have a setter, setforms assumes it's a data structure in functional
1992	; position. Such bugs will be seen only when the code is executed, when		2546	; position. Such bugs will be seen only when the code is executed, when
1993	; sref complains it can't set a reference to a function.		2547	; sref complains it can't set a reference to a function.
1994			2548
1995	(def setforms (expr0)		2549	(def setforms (expr0)
1996	(let expr (macex expr0)		2550	(let expr (macex expr0)
1997	(if (isa expr 'sym)		2551	(if (isa expr 'sym)
		<>	2552	(if (ssyntax expr)
			2553	(setforms (ssexpand expr))
1998	(w/uniq (g h)		2554	(w/uniq (g h)
1999	(list (list g expr)		2555	(list (list g expr)
2000	g		2556	g
2001	`(fn (,h) (set ,expr ,h))))		2557	`(fn (,h) (assign ,expr ,h)))))
2002	; make it also work for uncompressed calls to compose	=	2558	; make it also work for uncompressed calls to compose
2003	(and (acons expr) (metafn (car expr)))		2559	(and (acons expr) (metafn (car expr)))
2004	(setforms (expand-metafn-call (ssexpand (car expr)) (cdr expr)))		2560	(setforms (expand-metafn-call (ssexpand (car expr)) (cdr expr)))
		-+	2561	(and (acons expr) (acons (car expr)) (is (caar expr) 'get))
			2562	(setforms (list (cadr expr) (cadr (car expr))))
2005	(let f (setter (car expr))	=	2563	(let f (setter (car expr))
2006	(if f		2564	(if f
2007	(f expr)		2565	(f expr)
2008	; assumed to be data structure in fn position		2566	; assumed to be data structure in fn position
2009	(do (when (caris (car expr) 'fn)		2567	(do (when (caris (car expr) 'fn)
2010	(warn "Inverting what looks like a function call"	<>	2568	(warn "Inverting what looks like a function call"
2011	expr0 expr))	=	2569	expr0 expr))
2012	(w/uniq (g h)		2570	(w/uniq (g h)
2013	(let argsyms (map [uniq] (cdr expr))		2571	(let argsyms (map [uniq] (cdr expr))
2014	(list (+ (list g (car expr))		2572	(list (+ (list g (car expr))
2015	(mappend list argsyms (cdr expr)))		2573	(mappend list argsyms (cdr expr)))
2016	`(,g ,@argsyms)		2574	`(,g ,@argsyms)
2017	`(fn (,h) (sref ,g ,h ,@argsyms)))))))))))	<>	2575	`(fn (,h) (sref ,g ,h ,(car argsyms))))))))))))
2018		=	2576
2019	(def metafn (x)		2577	(def metafn (x)
2020	(or (ssyntax x)		2578	(or (ssyntax x)
2021	(and (acons x) (in (car x) 'compose 'complement))))		2579	(and (acons x) (in (car x) 'compose 'complement))))
2022			2580
2023	(def expand-metafn-call (f args)		2581	(def expand-metafn-call (f args)
2024	(if (is (car f) 'compose)		2582	(if (is (car f) 'compose)
2025	((afn (fs)	<>	2583	((afn (fs)
2026	(if (caris (car fs) 'compose) ; nested compose		2584	(if (caris (car fs) 'compose) ; nested compose
2027	(self (join (cdr (car fs)) (cdr fs)))		2585	(self (join (cdr (car fs)) (cdr fs)))
2028	(cdr fs)		2586	(cdr fs)
2029	(list (car fs) (self (cdr fs)))		2587	(list (car fs) (self (cdr fs)))
2030	(cons (car fs) args)))		2588	(cons (car fs) args)))
2031	(cdr f))		2589	(cdr f))
			2590	(is (car f) 'no)
2032	(err "Can't invert " (cons f args))))		2591	(err "Can't invert " (cons f args))
			2592	(cons f args)))
2033		=	2593
2034	(def expand= (place val)		2594	(def expand= (place val)
2035	(if (isa place 'sym)	<>	2595	(if (and (isa place 'sym) (~ssyntax place))
2036	`(set ,place ,val)		2596	`(assign ,place ,val)
2037	(let (vars prev setter) (setforms place)	=	2597	(let (vars prev setter) (setforms place)
2038	(w/uniq g		2598	(w/uniq g
2039	`(atwith ,(+ vars (list g val))		2599	`(atwith ,(+ vars (list g val))
2040	(,setter ,g))))))		2600	(,setter ,g))))))
2041			2601
2042	(def expand=list (terms)		2602	(def expand=list (terms)
2043	`(do ,@(map (fn ((p v)) (expand= p v)) ; [apply expand= _]		2603	`(do ,@(map (fn ((p v)) (expand= p v)) ; [apply expand= _]
2044	(pair terms))))		2604	(pair terms))))
2045			2605
2046	(mac = args		2606	(mac = args
2047	(expand=list args))		2607	(expand=list args))
2048			2608
2049	(mac loop (start test update . body)		2609	(mac loop (start test update . body)
2050	(w/uniq (gfn gparm)		2610	(w/uniq (gfn gparm)
2051	`(do ,start		2611	`(do ,start
2052	((rfn ,gfn (,gparm)		2612	((rfn ,gfn (,gparm)
2053	(if ,gparm		2613	(if ,gparm
2054	(do ,@body ,update (,gfn ,test))))		2614	(do ,@body ,update (,gfn ,test))))
2055	,test))))		2615	,test))))
2056			2616
2057	(mac for (v init max . body)		2617	(mac for (v init max . body)
2058	(w/uniq (gi gm)		2618	(w/uniq (gi gm)
2059	`(with (,v nil ,gi ,init ,gm (+ ,max 1))		2619	`(with (,v nil ,gi ,init ,gm (+ ,max 1))
2060	(loop (set ,v ,gi) (< ,v ,gm) (set ,v (+ ,v 1))	<>	2620	(loop (assign ,v ,gi) (< ,v ,gm) (assign ,v (+ ,v 1))
2061	,@body))))	=	2621	,@body))))
2062			2622
		-+	2623	(mac down (v init min . body)
			2624	(w/uniq (gi gm)
			2625	`(with (,v nil ,gi ,init ,gm (- ,min 1))
			2626	(loop (assign ,v ,gi) (> ,v ,gm) (assign ,v (- ,v 1))
			2627	,@body))))
			2628
2063	(mac repeat (n . body)	=	2629	(mac repeat (n . body)
2064	`(for ,(uniq) 1 ,n ,@body))		2630	`(for ,(uniq) 1 ,n ,@body))
2065			2631
2066	; could bind index instead of gensym		2632	; could bind index instead of gensym
2067			2633
2068	(mac each (var expr . body)		2634	(mac each (var expr . body)
2069	(w/uniq (gseq g)	<>	2635	(w/uniq (gseq gf gv)
2070	`(let ,gseq ,expr	=	2636	`(let ,gseq ,expr
2071	(if (alist ,gseq)		2637	(if (alist ,gseq)
2072	((afn (,g)	<>	2638	((rfn ,gf (,gv)
2073	(when (acons ,g)		2639	(when (acons ,gv)
2074	(let ,var (car ,g) ,@body)		2640	(let ,var (car ,gv) ,@body)
2075	(self (cdr ,g))))		2641	(,gf (cdr ,gv))))
2076	,gseq)	=	2642	,gseq)
2077	(isa ,gseq 'table)		2643	(isa ,gseq 'table)
2078	(maptable (fn (,g ,var) ,@body)	<>	2644	(maptable (fn ,var ,@body)
2079	,gseq)	=	2645	,gseq)
2080	(for ,g 0 (- (len ,gseq) 1)	<>	2646	(for ,gv 0 (- (len ,gseq) 1)
2081	(let ,var (,gseq ,g) ,@body))))))		2647	(let ,var (,gseq ,gv) ,@body))))))
2082		=	2648
2083	; (nthcdr x y) = (subseq y x).	<>	2649	; (nthcdr x y) = (cut y x).
2084		=	2650
2085	(def subseq (seq start (o end (len seq)))	<>	2651	(def cut (seq start (o end))
			2652	(let end (if (no end) (len seq)
			2653	(< end 0) (+ (len seq) end)
			2654	end)
2086	(if (isa seq 'string)		2655	(if (isa seq 'string)
2087	(let s2 (newstring (- end start))		2656	(let s2 (newstring (- end start))
2088	(for i 0 (- end start 1)		2657	(for i 0 (- end start 1)
2089	(= (s2 i) (seq (+ start i))))		2658	(= (s2 i) (seq (+ start i))))
2090	s2)		2659	s2)
2091	(firstn (- end start) (nthcdr start seq))))		2660	(firstn (- end start) (nthcdr start seq)))))
2092		=	2661
2093	(mac ontable (k v h . body)	+-
2094	`(maptable (fn (,k ,v) ,@body) ,h))
2095
2096	(mac whilet (var test . body)	=	2662	(mac whilet (var test . body)
2097	(w/uniq (gf gp)		2663	(w/uniq (gf gp)
2098	`((rfn ,gf (,gp)		2664	`((rfn ,gf (,gp)
2099	(let ,var ,gp		2665	(let ,var ,gp
2100	(when ,var ,@body (,gf ,test))))		2666	(when ,var ,@body (,gf ,test))))
2101	,test)))		2667	,test)))
2102			2668
2103	(def last (seq)	<>	2669	(def last (xs)
2104	(if (no (cdr seq))		2670	(if (cdr xs)
2105	(car seq)		2671	(last (cdr xs))
2106	(last (cdr seq))))		2672	(car xs)))
2107		=	2673
2108	(def rem (test seq)		2674	(def rem (test seq)
2109	(let f (testify test)		2675	(let f (testify test)
2110	(if (alist seq)		2676	(if (alist seq)
2111	((afn (s)		2677	((afn (s)
2112	(if (no s) nil		2678	(if (no s) nil
2113	(f (car s)) (self (cdr s))		2679	(f (car s)) (self (cdr s))
2114	(cons (car s) (self (cdr s)))))		2680	(cons (car s) (self (cdr s)))))
2115	seq)		2681	seq)
2116	(coerce (rem test (coerce seq 'cons)) 'string))))		2682	(coerce (rem test (coerce seq 'cons)) 'string))))
2117			2683
		-+	2684	; Seems like keep doesn't need to testify-- would be better to
			2685	; be able to use tables as fns. But rem does need to, because
			2686	; often want to rem a table from a list. So maybe the right answer
			2687	; is to make keep the more primitive, not rem.
			2688
2118	(def keep (test seq)	=	2689	(def keep (test seq)
2119	(rem (complement (testify test)) seq))		2690	(rem (complement (testify test)) seq))
2120			2691
		<>	2692	;(def trues (f seq)
2121	(def trues (f seq) (rem nil (map f seq)))		2693	; (rem nil (map f seq)))
			2694
			2695	(def trues (f xs)
			2696	(and xs
			2697	(let fx (f (car xs))
			2698	(if fx
			2699	(cons fx (trues f (cdr xs)))
			2700	(trues f (cdr xs))))))
2122		=	2701
2123	(mac do1 args		2702	(mac do1 args
2124	(w/uniq g		2703	(w/uniq g
2125	`(let ,g ,(car args)		2704	`(let ,g ,(car args)
2126	,@(cdr args)		2705	,@(cdr args)
2127	,g)))		2706	,g)))
2128			2707
2129	; Would like to write a faster case based on table generated by a macro,		2708	; Would like to write a faster case based on table generated by a macro,
2130	; but can't insert objects into expansions in Mzscheme.		2709	; but can't insert objects into expansions in Mzscheme.
2131			2710
2132	(mac caselet (var expr . args)		2711	(mac caselet (var expr . args)
2133	(let ex (afn (args)		2712	(let ex (afn (args)
2134	(if (no (cdr args))		2713	(if (no (cdr args))
2135	(car args)		2714	(car args)
2136	`(if (is ,var ',(car args))		2715	`(if (is ,var ',(car args))
2137	,(cadr args)		2716	,(cadr args)
2138	,(self (cddr args)))))		2717	,(self (cddr args)))))
2139	`(let ,var ,expr ,(ex args))))		2718	`(let ,var ,expr ,(ex args))))
2140			2719
2141	(mac case (expr . args)		2720	(mac case (expr . args)
2142	`(caselet ,(uniq) ,expr ,@args))		2721	`(caselet ,(uniq) ,expr ,@args))
2143			2722
2144	(mac push (x place)		2723	(mac push (x place)
2145	(w/uniq gx		2724	(w/uniq gx
2146	(let (binds val setter) (setforms place)		2725	(let (binds val setter) (setforms place)
2147	`(let ,gx ,x		2726	`(let ,gx ,x
2148	(atwiths ,binds		2727	(atwiths ,binds
2149	(,setter (cons ,gx ,val)))))))		2728	(,setter (cons ,gx ,val)))))))
2150			2729
2151	(mac swap (place1 place2)		2730	(mac swap (place1 place2)
2152	(w/uniq (g1 g2)		2731	(w/uniq (g1 g2)
2153	(with ((binds1 val1 setter1) (setforms place1)		2732	(with ((binds1 val1 setter1) (setforms place1)
2154	(binds2 val2 setter2) (setforms place2))		2733	(binds2 val2 setter2) (setforms place2))
2155	`(atwiths ,(+ binds1 (list g1 val1) binds2 (list g2 val2))		2734	`(atwiths ,(+ binds1 (list g1 val1) binds2 (list g2 val2))
2156	(,setter1 ,g2)		2735	(,setter1 ,g2)
2157	(,setter2 ,g1)))))		2736	(,setter2 ,g1)))))
2158			2737
2159	(mac rotate places		2738	(mac rotate places
2160	(with (vars (map [uniq] places)		2739	(with (vars (map [uniq] places)
2161	forms (map setforms places))		2740	forms (map setforms places))
2162	`(atwiths ,(mappend (fn (g (binds val setter))		2741	`(atwiths ,(mappend (fn (g (binds val setter))
2163	(+ binds (list g val)))		2742	(+ binds (list g val)))
2164	vars		2743	vars
2165	forms)		2744	forms)
2166	,@(map (fn (g (binds val setter))		2745	,@(map (fn (g (binds val setter))
2167	(list setter g))		2746	(list setter g))
2168	(+ (cdr vars) (list (car vars)))		2747	(+ (cdr vars) (list (car vars)))
2169	forms))))		2748	forms))))
2170			2749
2171	(mac pop (place)		2750	(mac pop (place)
2172	(w/uniq g		2751	(w/uniq g
2173	(let (binds val setter) (setforms place)		2752	(let (binds val setter) (setforms place)
2174	`(atwiths ,(+ binds (list g val))		2753	`(atwiths ,(+ binds (list g val))
2175	(do1 (car ,g)		2754	(do1 (car ,g)
2176	(,setter (cdr ,g)))))))		2755	(,setter (cdr ,g)))))))
2177			2756
2178	(def adjoin (x xs (o test iso))		2757	(def adjoin (x xs (o test iso))
2179	(if (some [test x _] xs)		2758	(if (some [test x _] xs)
2180	xs		2759	xs
2181	(cons x xs)))		2760	(cons x xs)))
2182			2761
2183	(mac pushnew (x place . args)		2762	(mac pushnew (x place . args)
2184	(w/uniq gx		2763	(w/uniq gx
2185	(let (binds val setter) (setforms place)		2764	(let (binds val setter) (setforms place)
2186	`(atwiths ,(+ (list gx x) binds)		2765	`(atwiths ,(+ (list gx x) binds)
2187	(,setter (adjoin ,gx ,val ,@args))))))		2766	(,setter (adjoin ,gx ,val ,@args))))))
2188			2767
2189	(mac pull (test place)		2768	(mac pull (test place)
2190	(w/uniq g		2769	(w/uniq g
2191	(let (binds val setter) (setforms place)		2770	(let (binds val setter) (setforms place)
2192	`(atwiths ,(+ (list g test) binds)		2771	`(atwiths ,(+ (list g test) binds)
2193	(,setter (rem ,g ,val))))))		2772	(,setter (rem ,g ,val))))))
2194			2773
		-+	2774	(mac togglemem (x place . args)
			2775	(w/uniq gx
			2776	(let (binds val setter) (setforms place)
			2777	`(atwiths ,(+ (list gx x) binds)
			2778	(,setter (if (mem ,gx ,val)
			2779	(rem ,gx ,val)
			2780	(adjoin ,gx ,val ,@args)))))))
			2781
2195	(mac ++ (place (o i 1))	=	2782	(mac ++ (place (o i 1))
2196	(if (isa place 'sym)		2783	(if (isa place 'sym)
2197	`(= ,place (+ ,place ,i))		2784	`(= ,place (+ ,place ,i))
2198	(w/uniq gi		2785	(w/uniq gi
2199	(let (binds val setter) (setforms place)		2786	(let (binds val setter) (setforms place)
2200	`(atwiths ,(+ binds (list gi i))		2787	`(atwiths ,(+ binds (list gi i))
2201	(,setter (+ ,val ,gi)))))))		2788	(,setter (+ ,val ,gi)))))))
2202			2789
2203	(mac -- (place (o i 1))		2790	(mac -- (place (o i 1))
2204	(if (isa place 'sym)		2791	(if (isa place 'sym)
2205	`(= ,place (- ,place ,i))		2792	`(= ,place (- ,place ,i))
2206	(w/uniq gi		2793	(w/uniq gi
2207	(let (binds val setter) (setforms place)		2794	(let (binds val setter) (setforms place)
2208	`(atwiths ,(+ binds (list gi i))		2795	`(atwiths ,(+ binds (list gi i))
2209	(,setter (- ,val ,gi)))))))		2796	(,setter (- ,val ,gi)))))))
2210			2797
2211	; E.g. (inc x) equiv to (zap + x 1)	<>	2798	; E.g. (++ x) equiv to (zap + x 1)
2212		=	2799
2213	(mac zap (op place . args)		2800	(mac zap (op place . args)
2214	(with (gop (uniq)		2801	(with (gop (uniq)
2215	gargs (map [uniq] args)		2802	gargs (map [uniq] args)
2216	mix (afn seqs		2803	mix (afn seqs
2217	(if (some no seqs)		2804	(if (some no seqs)
2218	nil		2805	nil
2219	(+ (map car seqs)		2806	(+ (map car seqs)
2220	(apply self (map cdr seqs))))))		2807	(apply self (map cdr seqs))))))
2221	(let (binds val setter) (setforms place)		2808	(let (binds val setter) (setforms place)
2222	`(atwiths ,(+ binds (list gop op) (mix gargs args))		2809	`(atwiths ,(+ binds (list gop op) (mix gargs args))
2223	(,setter (,gop ,val ,@gargs))))))		2810	(,setter (,gop ,val ,@gargs))))))
2224			2811
2225	; Can't simply mod pr to print strings represented as lists of chars,		2812	; Can't simply mod pr to print strings represented as lists of chars,
2226	; because empty string will get printed as nil. Would need to rep strings		2813	; because empty string will get printed as nil. Would need to rep strings
2227	; as lists of chars annotated with 'string, and modify car and cdr to get		2814	; as lists of chars annotated with 'string, and modify car and cdr to get
2228	; the rep of these. That would also require hacking the reader.		2815	; the rep of these. That would also require hacking the reader.
2229			2816
2230	;(def pr args	+-
2231	; (if (isa (car args) 'output)
2232	; (do (error "stream arg!" args)
2233	; (map1 [disp _ (car args)] (cdr args))
2234	; (cadr args))
2235	; (do (map1 disp args)
2236	; (car args))))
2237
2238	(def pr args	=	2817	(def pr args
2239	(map1 disp args)		2818	(map1 disp args)
2240	(car args))		2819	(car args))
2241			2820
2242	; Rtm says this version should make the server 20% faster because map1	<>
2243	; generates so much garbage; in fact makes slower; maybe rewrite map1?
2244
2245	;(def newpr args		2821	(def prt args
2246	; (if (isa (car args) 'output)		2822	(map1 [if _ (disp _)] args)
2247	; (do (each a (cdr args) (disp a (car args)))
2248	; (cadr args))		2823	(car args))
2249	; (do (each a args (disp a))
2250	; (car args))))
2251		=	2824
2252	(def prn args		2825	(def prn args
2253	(do1 (apply pr args)		2826	(do1 (apply pr args)
2254	(writec #\newline	<>	2827	(writec #\newline)))
2255	(if (isa (car args) 'output) (car args) (stdout)))))
2256		=	2828
2257	(mac nil! args	<>	2829	(mac wipe args
2258	`(do ,@(map (fn (a) `(= ,a nil)) args)))	=	2830	`(do ,@(map (fn (a) `(= ,a nil)) args)))
2259			2831
2260	(mac t! args	<>	2832	(mac set args
2261	`(do ,@(map (fn (a) `(= ,a t)) args)))	=	2833	`(do ,@(map (fn (a) `(= ,a t)) args)))
2262			2834
2263	; Destructing means ambiguity: are pat vars bound in else? (no)	<>	2835	; Destructuring means ambiguity: are pat vars bound in else? (no)
2264		=	2836
2265	(mac iflet (var expr then . rest)		2837	(mac iflet (var expr then . rest)
2266	(w/uniq gv		2838	(w/uniq gv
2267	`(let ,gv ,expr		2839	`(let ,gv ,expr
2268	(if ,gv (let ,var ,gv ,then) ,@rest))))		2840	(if ,gv (let ,var ,gv ,then) ,@rest))))
2269			2841
2270	(mac whenlet (var expr . body)		2842	(mac whenlet (var expr . body)
2271	`(iflet ,var ,expr (do ,@body)))		2843	`(iflet ,var ,expr (do ,@body)))
2272			2844
2273	(mac aif (expr . body)		2845	(mac aif (expr . body)
2274	`(let it ,expr (if it ,@body)))	<>	2846	`(let it ,expr
			2847	(if it
			2848	,@(if (cddr body)
			2849	`(,(car body) (aif ,@(cdr body)))
			2850	body))))
2275		=	2851
2276	(mac awhen (expr . body)		2852	(mac awhen (expr . body)
2277	`(let it ,expr (if it (do ,@body))))		2853	`(let it ,expr (if it (do ,@body))))
2278			2854
2279	(mac aand args		2855	(mac aand args
2280	(if (no args)		2856	(if (no args)
2281	't		2857	't
2282	(no (cdr args))		2858	(no (cdr args))
2283	(car args)		2859	(car args)
2284	`(let it ,(car args) (and it (aand ,@(cdr args))))))		2860	`(let it ,(car args) (and it (aand ,@(cdr args))))))
2285			2861
2286	(mac accum (accfn . body)		2862	(mac accum (accfn . body)
2287	(w/uniq gacc		2863	(w/uniq gacc
2288	`(withs (,gacc nil ,accfn [push _ ,gacc])		2864	`(withs (,gacc nil ,accfn [push _ ,gacc])
2289	,@body		2865	,@body
2290	,gacc)))	<>	2866	(rev ,gacc))))
2291		=	2867
2292	; Repeatedly evaluates its body till it returns nil, then returns vals.		2868	; Repeatedly evaluates its body till it returns nil, then returns vals.
2293			2869
2294	(mac drain (expr (o eof nil))		2870	(mac drain (expr (o eof nil))
2295	(w/uniq (gacc gdone gres)		2871	(w/uniq (gacc gdone gres)
2296	`(with (,gacc nil ,gdone nil)		2872	`(with (,gacc nil ,gdone nil)
2297	(while (no ,gdone)		2873	(while (no ,gdone)
2298	(let ,gres ,expr		2874	(let ,gres ,expr
2299	(if (is ,gres ,eof)		2875	(if (is ,gres ,eof)
2300	(= ,gdone t)		2876	(= ,gdone t)
2301	(push ,gres ,gacc))))		2877	(push ,gres ,gacc))))
2302	(rev ,gacc))))		2878	(rev ,gacc))))
2303			2879
2304	; For the common C idiom while x = snarfdata != stopval.		2880	; For the common C idiom while x = snarfdata != stopval.
2305	; Rename this if use it often.		2881	; Rename this if use it often.
2306			2882
2307	(mac whiler (var expr endval . body)		2883	(mac whiler (var expr endval . body)
2308	(w/uniq gf		2884	(w/uniq gf
2309	`((rfn ,gf (,var)	<>	2885	`(withs (,var nil ,gf (testify ,endval))
2310	(when (and ,var (no (is ,var ,endval)))		2886	(while (no (,gf (= ,var ,expr)))
2311	,@body		2887	,@body))))
2312	(,gf ,expr)))
2313	,expr)))
2314		=	2888
2315	;(def macex (e)		2889	;(def macex (e)
2316	; (if (atom e)		2890	; (if (atom e)
2317	; e		2891	; e
2318	; (let op (and (atom (car e)) (eval (car e)))		2892	; (let op (and (atom (car e)) (eval (car e)))
2319	; (if (isa op 'mac)		2893	; (if (isa op 'mac)
2320	; (apply (rep op) (cdr e))		2894	; (apply (rep op) (cdr e))
2321	; e))))		2895	; e))))
2322			2896
2323	(def consif (x y) (if x (cons x y) y))		2897	(def consif (x y) (if x (cons x y) y))
2324			2898
2325	(def string args		2899	(def string args
2326	(apply + "" (map [coerce _ 'string] args)))		2900	(apply + "" (map [coerce _ 'string] args)))
2327			2901
2328	(def flat (x (o stringstoo))	<>	2902	(def flat x
2329	((rfn f (x acc)		2903	((afn (x acc)
2330	(if (or (no x) (and stringstoo (is x "")))
2331	acc		2904	(if (no x) acc
2332	(and (atom x) (no (and stringstoo (isa x 'string))))
2333	(cons x acc)		2905	(atom x) (cons x acc)
2334	(f (car x) (f (cdr x) acc))))		2906	(self (car x) (self (cdr x) acc))))
2335	x nil))	=	2907	x nil))
2336			2908
2337	; Perhaps not the final idea, or at least final name	<>
2338
2339	(mac default (x test alt)		2909	(mac check (x test (o alt))
2340	(w/uniq gx	=	2910	(w/uniq gx
2341	`(let ,gx ,x		2911	`(let ,gx ,x
2342	(if (,test ,gx) ,gx ,alt))))		2912	(if (,test ,gx) ,gx ,alt))))
2343			2913
2344	(def pos (test seq (o start 0))		2914	(def pos (test seq (o start 0))
2345	(let f (testify test)		2915	(let f (testify test)
2346	(if (alist seq)		2916	(if (alist seq)
2347	((afn (seq n)		2917	((afn (seq n)
2348	(if (no seq)		2918	(if (no seq)
2349	nil		2919	nil
2350	(f (car seq))		2920	(f (car seq))
2351	n		2921	n
2352	(self (cdr seq) (+ n 1))))		2922	(self (cdr seq) (+ n 1))))
2353	(nthcdr start seq)		2923	(nthcdr start seq)
2354	start)		2924	start)
2355	(recstring [if (f (seq _)) _] seq start))))		2925	(recstring [if (f (seq _)) _] seq start))))
2356			2926
2357	(def even (n) (is (mod n 2) 0))		2927	(def even (n) (is (mod n 2) 0))
2358			2928
2359	(def odd (n) (no (even n)))		2929	(def odd (n) (no (even n)))
2360			2930
2361	(mac after (x . ys)		2931	(mac after (x . ys)
2362	`(protect (fn () ,x) (fn () ,@ys)))		2932	`(protect (fn () ,x) (fn () ,@ys)))
2363			2933
2364	(let expander		2934	(let expander
2365	(fn (f var name body)		2935	(fn (f var name body)
2366	`(let ,var (,f ,name)		2936	`(let ,var (,f ,name)
2367	(after (do ,@body) (close ,var))))		2937	(after (do ,@body) (close ,var))))
2368			2938
2369	(mac w/infile (var name . body)		2939	(mac w/infile (var name . body)
2370	(expander 'infile var name body))		2940	(expander 'infile var name body))
2371			2941
2372	(mac w/outfile (var name . body)		2942	(mac w/outfile (var name . body)
2373	(expander 'outfile var name body))		2943	(expander 'outfile var name body))
2374			2944
2375	(mac w/instring (var str . body)		2945	(mac w/instring (var str . body)
2376	(expander 'instring var str body))		2946	(expander 'instring var str body))
		-+	2947
			2948	(mac w/socket (var port . body)
			2949	(expander 'open-socket var port body))
2377	)	=	2950	)
2378			2951
2379	(mac w/outstring (var . body)		2952	(mac w/outstring (var . body)
2380	`(let ,var (outstring) ,@body))		2953	`(let ,var (outstring) ,@body))
		-+	2954
			2955	; what happens to a file opened for append if arc is killed in
			2956	; the middle of a write?
2381		=	2957
2382	(mac w/appendfile (var name . body)		2958	(mac w/appendfile (var name . body)
2383	`(let ,var (outfile ,name 'append)		2959	`(let ,var (outfile ,name 'append)
2384	(after (do ,@body) (close ,var))))		2960	(after (do ,@body) (close ,var))))
2385			2961
2386	; rename this simply "to"? - prob not; rarely use		2962	; rename this simply "to"? - prob not; rarely use
2387			2963
2388	(mac w/stdout (str . body)		2964	(mac w/stdout (str . body)
2389	`(call-w/stdout ,str (fn () ,@body)))		2965	`(call-w/stdout ,str (fn () ,@body)))
2390			2966
2391	(mac w/stdin (str . body)		2967	(mac w/stdin (str . body)
2392	`(call-w/stdin ,str (fn () ,@body)))		2968	`(call-w/stdin ,str (fn () ,@body)))
2393			2969
2394	(mac tostring body		2970	(mac tostring body
2395	(w/uniq gv		2971	(w/uniq gv
2396	`(w/outstring ,gv		2972	`(w/outstring ,gv
2397	(w/stdout ,gv ,@body)		2973	(w/stdout ,gv ,@body)
2398	(inside ,gv))))		2974	(inside ,gv))))
2399			2975
2400	(mac fromstring (str . body)		2976	(mac fromstring (str . body)
2401	(w/uniq gv		2977	(w/uniq gv
2402	`(w/instring ,gv ,str		2978	`(w/instring ,gv ,str
2403	(w/stdin ,gv ,@body))))		2979	(w/stdin ,gv ,@body))))
2404			2980
2405	(def readstring1 (s (o eof nil)) (w/instring i s (read i eof)))		2981	(def readstring1 (s (o eof nil)) (w/instring i s (read i eof)))
2406			2982
2407	(def read ((o x (stdin)) (o eof nil))		2983	(def read ((o x (stdin)) (o eof nil))
2408	(if (isa x 'string) (readstring1 x eof) (sread x eof)))		2984	(if (isa x 'string) (readstring1 x eof) (sread x eof)))
2409			2985
		-+	2986	; inconsistency between names of readfile[1] and writefile
			2987
2410	(def readfile (name) (w/infile s name (drain (read s))))	=	2988	(def readfile (name) (w/infile s name (drain (read s))))
2411			2989
2412	(def readfile1 (name) (w/infile s name (read s)))		2990	(def readfile1 (name) (w/infile s name (read s)))
2413			2991
2414	(def writefile1 (val name) (w/outfile s name (write val s)) val)	+-
2415
2416	(def readall (src (o eof nil))	=	2992	(def readall (src (o eof nil))
2417	((afn (i)		2993	((afn (i)
2418	(let x (read i eof)		2994	(let x (read i eof)
2419	(if (is x eof)		2995	(if (is x eof)
2420	nil		2996	nil
2421	(cons x (self i)))))		2997	(cons x (self i)))))
2422	(if (isa src 'string) (instring src) src)))		2998	(if (isa src 'string) (instring src) src)))
2423			2999
		-+	3000	(def allchars (str)
			3001	(tostring (whiler c (readc str nil) no
			3002	(writec c))))
			3003
			3004	(def filechars (name)
			3005	(w/infile s name (allchars s)))
			3006
			3007	(def writefile (val file)
			3008	(let tmpfile (+ file ".tmp")
			3009	(w/outfile o tmpfile (write val o))
			3010	(mvfile tmpfile file))
			3011	val)
			3012
2424	(def sym (x) (coerce x 'sym))	=	3013	(def sym (x) (coerce x 'sym))
		-+	3014
			3015	(def int (x (o b 10)) (coerce x 'int b))
2425		=	3016
2426	(mac rand-choice exprs		3017	(mac rand-choice exprs
2427	`(case (rand ,(len exprs))		3018	`(case (rand ,(len exprs))
2428	,@(let key -1		3019	,@(let key -1
2429	(mappend [list (++ key) _]		3020	(mappend [list (++ key) _]
2430	exprs))))		3021	exprs))))
2431			3022
2432	(mac n-of (n expr)		3023	(mac n-of (n expr)
2433	(w/uniq ga		3024	(w/uniq ga
2434	`(let ,ga nil		3025	`(let ,ga nil
2435	(repeat ,n (push ,expr ,ga))		3026	(repeat ,n (push ,expr ,ga))
2436	(rev ,ga))))		3027	(rev ,ga))))
2437			3028
		-+	3029	; rejects bytes >= 248 lest digits be overrepresented
			3030
2438	(def rand-string (n)	=	3031	(def rand-string (n)
		<>	3032	(let c "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
2439	(with (cap (fn () (+ 65 (rand 26)))		3033	(with (nc 62 s (newstring n) i 0)
2440	sm (fn () (+ 97 (rand 26)))		3034	(w/infile str "/dev/urandom"
2441	dig (fn () (+ 48 (rand 10))))		3035	(while (< i n)
2442	(coerce (map [coerce _ 'char]		3036	(let x (readb str)
			3037	(unless (> x 247)
2443	(cons (rand-choice (cap) (sm))		3038	(= (s i) (c (mod x nc)))
2444	(n-of (- n 1) (rand-choice (cap) (sm) (dig)))))		3039	(++ i)))))
2445	'string)))		3040	s)))
2446		=	3041
2447	(mac forlen (var s . body)		3042	(mac forlen (var s . body)
2448	`(for ,var 0 (- (len ,s) 1) ,@body))		3043	`(for ,var 0 (- (len ,s) 1) ,@body))
2449			3044
2450	(mac on (var s . body)		3045	(mac on (var s . body)
2451	(if (is var 'index)		3046	(if (is var 'index)
2452	(err "Can't use index as first arg to on.")		3047	(err "Can't use index as first arg to on.")
2453	(w/uniq gs		3048	(w/uniq gs
2454	`(let ,gs ,s		3049	`(let ,gs ,s
2455	(forlen index ,gs		3050	(forlen index ,gs
2456	(let ,var (,gs index)		3051	(let ,var (,gs index)
2457	,@body))))))		3052	,@body))))))
2458			3053
2459	(def best (f seq)		3054	(def best (f seq)
2460	(if (no seq)		3055	(if (no seq)
2461	nil		3056	nil
2462	(let wins (car seq)		3057	(let wins (car seq)
2463	(each elt (cdr seq)		3058	(each elt (cdr seq)
2464	(if (f elt wins) (= wins elt)))		3059	(if (f elt wins) (= wins elt)))
2465	wins)))		3060	wins)))
2466			3061
2467	(def max args (best > args))		3062	(def max args (best > args))
2468	(def min args (best < args))		3063	(def min args (best < args))
2469			3064
2470	; (mac max2 (x y)		3065	; (mac max2 (x y)
2471	; (w/uniq (a b)		3066	; (w/uniq (a b)
2472	; `(with (,a ,x ,b ,y) (if (> ,a ,b) ,a ,b))))		3067	; `(with (,a ,x ,b ,y) (if (> ,a ,b) ,a ,b))))
2473			3068
2474	(def most (f seq)		3069	(def most (f seq)
2475	(unless (no seq)		3070	(unless (no seq)
2476	(withs (wins (car seq) topscore (f wins))		3071	(withs (wins (car seq) topscore (f wins))
2477	(each elt (cdr seq)		3072	(each elt (cdr seq)
2478	(let score (f elt)		3073	(let score (f elt)
2479	(if (> score topscore) (= wins elt topscore score))))		3074	(if (> score topscore) (= wins elt topscore score))))
2480	wins)))		3075	wins)))
2481			3076
2482	; Insert so that list remains sorted. Don't really want to expose		3077	; Insert so that list remains sorted. Don't really want to expose
2483	; these but seem to have to because can't include a fn obj in a		3078	; these but seem to have to because can't include a fn obj in a
2484	; macroexpansion.		3079	; macroexpansion.
2485			3080
2486	(def insert-sorted (test elt seq)		3081	(def insert-sorted (test elt seq)
2487	(if (no seq)		3082	(if (no seq)
2488	(list elt)		3083	(list elt)
2489	(test elt (car seq))		3084	(test elt (car seq))
2490	(cons elt seq)		3085	(cons elt seq)
2491	(cons (car seq) (insert-sorted test elt (cdr seq)))))		3086	(cons (car seq) (insert-sorted test elt (cdr seq)))))
2492			3087
2493	(mac insort (test elt seq)		3088	(mac insort (test elt seq)
2494	`(zap [insert-sorted ,test ,elt _] ,seq))		3089	`(zap [insert-sorted ,test ,elt _] ,seq))
2495			3090
2496	(def reinsert-sorted (test elt seq)		3091	(def reinsert-sorted (test elt seq)
2497	(if (no seq)		3092	(if (no seq)
2498	(list elt)		3093	(list elt)
2499	(is elt (car seq))		3094	(is elt (car seq))
2500	(reinsert-sorted test elt (cdr seq))		3095	(reinsert-sorted test elt (cdr seq))
2501	(test elt (car seq))		3096	(test elt (car seq))
2502	(cons elt (rem elt seq))		3097	(cons elt (rem elt seq))
2503	(cons (car seq) (reinsert-sorted test elt (cdr seq)))))		3098	(cons (car seq) (reinsert-sorted test elt (cdr seq)))))
2504			3099
2505	(mac insortnew (test elt seq)		3100	(mac insortnew (test elt seq)
2506	`(zap [reinsert-sorted ,test ,elt _] ,seq))		3101	`(zap [reinsert-sorted ,test ,elt _] ,seq))
2507			3102
2508	; Could make this look at the sig of f and return a fn that took the		3103	; Could make this look at the sig of f and return a fn that took the
2509	; right no of args and didn't have to call apply (or list if 1 arg).		3104	; right no of args and didn't have to call apply (or list if 1 arg).
2510			3105
2511	(def memo (f)		3106	(def memo (f)
2512	(let cache (table)	<>	3107	(with (cache (table) nilcache (table))
2513	(fn args	=	3108	(fn args
2514	(or (cache args)		3109	(or (cache args)
		<>	3110	(and (no (nilcache args))
			3111	(aif (apply f args)
			3112	(= (cache args) it)
			3113	(do (set (nilcache args))
			3114	nil)))))))
2515	(= (cache args) (apply f args))))))		3115
2516		=	3116
2517	(mac defmemo (name parms . body)		3117	(mac defmemo (name parms . body)
2518	`(safeset ,name (memo (fn ,parms ,@body))))		3118	`(safeset ,name (memo (fn ,parms ,@body))))
2519			3119
2520	(def <= args		3120	(def <= args
2521	(or (no args)	<>	3121	(or (no args)
2522	(no (cdr args))	=	3122	(no (cdr args))
2523	(and (no (> (car args) (cadr args)))		3123	(and (no (> (car args) (cadr args)))
2524	(apply <= (cdr args)))))		3124	(apply <= (cdr args)))))
2525			3125
2526	(def >= args		3126	(def >= args
2527	(or (no args)	<>	3127	(or (no args)
2528	(no (cdr args))	=	3128	(no (cdr args))
2529	(and (no (< (car args) (cadr args)))		3129	(and (no (< (car args) (cadr args)))
2530	(apply >= (cdr args)))))		3130	(apply >= (cdr args)))))
2531		<>	3131
2532	(def whitec (c)	=	3132	(def whitec (c)
2533	(in c #\space #\newline #\tab #\return))		3133	(in c #\space #\newline #\tab #\return))
2534			3134
2535	(def nonwhite (c) (no (whitec c)))		3135	(def nonwhite (c) (no (whitec c)))
2536			3136
		<>	3137	(def letter (c) (or (<= #\a c #\z) (<= #\A c #\Z)))
2537	(def alphadig (c)		3138
			3139	(def digit (c) (<= #\0 c #\9))
2538	(or (<= #\a c #\z) (<= #\A c #\Z) (<= #\0 c #\9)))		3140
			3141	(def alphadig (c) (or (letter c) (digit c)))
2539		=	3142
2540	(def punc (c)		3143	(def punc (c)
2541	(in c #\. #\, #\; #\: #\! #\?))		3144	(in c #\. #\, #\; #\: #\! #\?))
2542			3145
2543	(def readline ((o str (stdin)))		3146	(def readline ((o str (stdin)))
2544	(awhen (readc str)		3147	(awhen (readc str)
2545	(tostring		3148	(tostring
2546	(writec it)		3149	(writec it)
2547	(whiler c (readc str) #\newline	<>	3150	(whiler c (readc str) [in _ nil #\newline]
2548	(writec c)))))	=	3151	(writec c)))))
2549			3152
2550	; Don't currently use this but suspect some code could.		3153	; Don't currently use this but suspect some code could.
2551			3154
2552	(mac summing (sumfn . body)		3155	(mac summing (sumfn . body)
2553	(w/uniq (gc gt)		3156	(w/uniq (gc gt)
2554	`(let ,gc 0		3157	`(let ,gc 0
2555	(let ,sumfn (fn (,gt) (if ,gt (++ ,gc)))		3158	(let ,sumfn (fn (,gt) (if ,gt (++ ,gc)))
2556	,@body)		3159	,@body)
2557	,gc)))		3160	,gc)))
2558			3161
		<>	3162	(def sum (f xs)
			3163	(let n 0
			3164	(each x xs (++ n (f x)))
			3165	n))
			3166
2559	(def trav (f base tree)		3167	(def treewise (f base tree)
2560	(if (atom tree)	=	3168	(if (atom tree)
2561	(base tree)		3169	(base tree)
		<>	3170	(f (treewise f base (car tree))
2562	(f (trav f base (car tree)) (trav f base (cdr tree)))))		3171	(treewise f base (cdr tree)))))
2563		=	3172
2564	(def carif (x) (if (atom x) x (car x)))		3173	(def carif (x) (if (atom x) x (car x)))
2565			3174
2566	; Could prob be generalized beyond printing.		3175	; Could prob be generalized beyond printing.
2567			3176
2568	(def prall (elts (o init "") (o sep ", "))		3177	(def prall (elts (o init "") (o sep ", "))
2569	(when elts		3178	(when elts
2570	(pr init (car elts))		3179	(pr init (car elts))
2571	(map [pr sep _] (cdr elts))		3180	(map [pr sep _] (cdr elts))
2572	elts))		3181	elts))
2573			3182
2574	(def prs args		3183	(def prs args
2575	(prall args "" #\space))		3184	(prall args "" #\space))
2576			3185
2577	(def tree-subst (old new tree)		3186	(def tree-subst (old new tree)
2578	(if (is tree old)		3187	(if (is tree old)
2579	new		3188	new
2580	(atom tree)		3189	(atom tree)
2581	tree		3190	tree
2582	(cons (tree-subst old new (car tree))		3191	(cons (tree-subst old new (car tree))
2583	(tree-subst old new (cdr tree)))))		3192	(tree-subst old new (cdr tree)))))
2584			3193
2585	(def ontree (f tree)		3194	(def ontree (f tree)
2586	(f tree)		3195	(f tree)
2587	(unless (atom tree)		3196	(unless (atom tree)
2588	(ontree f (car tree))		3197	(ontree f (car tree))
2589	(ontree f (cdr tree))))		3198	(ontree f (cdr tree))))
2590			3199
2591	(def dotted (x)		3200	(def dotted (x)
2592	(if (atom x)		3201	(if (atom x)
2593	nil		3202	nil
2594	(and (cdr x) (or (atom (cdr x))		3203	(and (cdr x) (or (atom (cdr x))
2595	(dotted (cdr x))))))		3204	(dotted (cdr x))))))
2596			3205
2597	(def fill-table (table data)		3206	(def fill-table (table data)
2598	(each (k v) (pair data) (= (table k) v))		3207	(each (k v) (pair data) (= (table k) v))
2599	table)		3208	table)
2600			3209
2601	(mac obj args	+-
2602	(w/uniq g
2603	`(let ,g (table)
2604	,@(map (fn ((k v)) `(= (,g ',k) ,v))
2605	(pair args))
2606	,g)))
2607
2608	(def keys (h)	=	3210	(def keys (h)
2609	(accum a (ontable k v h (a k))))	<>	3211	(accum a (each (k v) h (a k))))
2610		=	3212
2611	(def vals (h)		3213	(def vals (h)
2612	(accum a (ontable k v h (a v))))	<>	3214	(accum a (each (k v) h (a v))))
2613		=	3215
2614	; These two should really be done by coerce. Wrap coerce?		3216	; These two should really be done by coerce. Wrap coerce?
2615			3217
2616	(def tablist (h)		3218	(def tablist (h)
2617	(accum a (maptable (fn args (a args)) h)))		3219	(accum a (maptable (fn args (a args)) h)))
2618			3220
2619	(def listtab (al)		3221	(def listtab (al)
2620	(let h (table)		3222	(let h (table)
2621	(map (fn ((k v)) (= (h k) v))		3223	(map (fn ((k v)) (= (h k) v))
2622	al)		3224	al)
2623	h))		3225	h))
		-+	3226
			3227	(mac obj args
			3228	`(listtab (list ,@(map (fn ((k v))
			3229	`(list ',k ,v))
			3230	(pair args)))))
2624		=	3231
2625	(def load-table (file (o eof))		3232	(def load-table (file (o eof))
2626	(w/infile i file (read-table i eof)))		3233	(w/infile i file (read-table i eof)))
2627			3234
2628	(def read-table ((o i (stdin)) (o eof))		3235	(def read-table ((o i (stdin)) (o eof))
2629	(let e (read i eof)		3236	(let e (read i eof)
2630	(if (alist e) (listtab e) e)))		3237	(if (alist e) (listtab e) e)))
2631			3238
2632	(def load-tables (file)		3239	(def load-tables (file)
2633	(w/infile i file		3240	(w/infile i file
2634	(w/uniq eof		3241	(w/uniq eof
2635	(drain (read-table i eof) eof))))		3242	(drain (read-table i eof) eof))))
2636			3243
2637	(def save-table (h file)		3244	(def save-table (h file)
2638	(w/outfile o file (write-table h o)))	<>	3245	(writefile (tablist h) file))
2639		=	3246
2640	(def write-table (h (o o (stdout)))		3247	(def write-table (h (o o (stdout)))
2641	(write (tablist h) o))		3248	(write (tablist h) o))
2642			3249
2643	(def copy (x)	<>	3250	(def copy (x . args)
2644	(case (type x)		3251	(let x2 (case (type x)
2645	sym x		3252	sym x
2646	cons (apply (fn args args) x)		3253	cons (copylist x) ; (apply (fn args args) x)
2647	string (let new (newstring (len x))		3254	string (let new (newstring (len x))
2648	(forlen i x		3255	(forlen i x
2649	(= (new i) (x i)))		3256	(= (new i) (x i)))
2650	new)		3257	new)
2651	table (let new (table)		3258	table (let new (table)
2652	(ontable k v x		3259	(each (k v) x
2653	(= (new k) v))		3260	(= (new k) v))
2654	new)		3261	new)
2655	(err "Can't copy " x)))		3262	(err "Can't copy " x))
			3263	(map (fn ((k v)) (= (x2 k) v))
			3264	(pair args))
			3265	x2))
2656		=	3266
2657	(def abs (n)		3267	(def abs (n)
2658	(if (< n 0) (- n) n))		3268	(if (< n 0) (- n) n))
2659			3269
2660	; The problem with returning a list instead of multiple values is that		3270	; The problem with returning a list instead of multiple values is that
2661	; you can't act as if the fn didn't return multiple vals in cases where		3271	; you can't act as if the fn didn't return multiple vals in cases where
2662	; you only want the first. Not a big problem.		3272	; you only want the first. Not a big problem.
2663			3273
2664	(def round (n)		3274	(def round (n)
2665	(withs (base (truncate n) rem (abs (- n base)))	<>	3275	(withs (base (trunc n) rem (abs (- n base)))
2666	(if (> rem 1/2) ((if (> n 0) + -) base 1)	=	3276	(if (> rem 1/2) ((if (> n 0) + -) base 1)
2667	(< rem 1/2) base		3277	(< rem 1/2) base
2668	(odd base) ((if (> n 0) + -) base 1)		3278	(odd base) ((if (> n 0) + -) base 1)
2669	base)))		3279	base)))
2670			3280
2671	(def roundup (n)		3281	(def roundup (n)
2672	(withs (base (truncate n) rem (abs (- n base)))	<>	3282	(withs (base (trunc n) rem (abs (- n base)))
2673	(if (>= rem 1/2)	=	3283	(if (>= rem 1/2)
2674	((if (> n 0) + -) base 1)		3284	((if (> n 0) + -) base 1)
2675	base)))		3285	base)))
2676			3286
2677	(def to-nearest (n quantum)	<>	3287	(def nearest (n quantum)
2678	(* (roundup (/ n quantum)) quantum))	=	3288	(* (roundup (/ n quantum)) quantum))
2679			3289
2680	(def avg (ns) (/ (apply + ns) (len ns)))		3290	(def avg (ns) (/ (apply + ns) (len ns)))
		-+	3291
			3292	(def med (ns (o test >))
			3293	((sort test ns) (round (/ (len ns) 2))))
2681		=	3294
2682	; Use mergesort on assumption that mostly sorting mostly sorted lists		3295	; Use mergesort on assumption that mostly sorting mostly sorted lists
2683	; benchmark: (let td (n-of 10000 (rand 100)) (time (sort < td)) 1)		3296	; benchmark: (let td (n-of 10000 (rand 100)) (time (sort < td)) 1)
2684			3297
2685	(def sort (test seq)		3298	(def sort (test seq)
2686	(if (alist seq)		3299	(if (alist seq)
2687	(mergesort test (copy seq))		3300	(mergesort test (copy seq))
2688	(coerce (mergesort test (coerce seq 'cons)) (type seq))))		3301	(coerce (mergesort test (coerce seq 'cons)) (type seq))))
2689			3302
2690	; Destructive stable merge-sort, adapted from slib and improved		3303	; Destructive stable merge-sort, adapted from slib and improved
2691	; by Eli Barzilay for MzLib; re-written in Arc.		3304	; by Eli Barzilay for MzLib; re-written in Arc.
2692			3305
2693	(def mergesort (less? lst)		3306	(def mergesort (less? lst)
2694	(with (n (len lst))		3307	(with (n (len lst))
2695	(if (<= n 1) lst		3308	(if (<= n 1) lst
2696	; ; check if the list is already sorted		3309	; ; check if the list is already sorted
2697	; ; (which can be a common case, eg, directory lists).		3310	; ; (which can be a common case, eg, directory lists).
2698	; (let loop ([last (car lst)] [next (cdr lst)])		3311	; (let loop ([last (car lst)] [next (cdr lst)])
2699	; (or (null? next)		3312	; (or (null? next)
2700	; (and (not (less? (car next) last))		3313	; (and (not (less? (car next) last))
2701	; (loop (car next) (cdr next)))))		3314	; (loop (car next) (cdr next)))))
2702	; lst		3315	; lst
2703	((afn (n)		3316	((afn (n)
2704	(if (> n 2)		3317	(if (> n 2)
2705	; needs to evaluate L->R		3318	; needs to evaluate L->R
2706	(withs (j (/ (if (even n) n (- n 1)) 2) ; faster than round		3319	(withs (j (/ (if (even n) n (- n 1)) 2) ; faster than round
2707	a (self j)		3320	a (self j)
2708	b (self (- n j)))		3321	b (self (- n j)))
2709	(merge less? a b))		3322	(merge less? a b))
2710	; the following case just inlines the length 2 case,		3323	; the following case just inlines the length 2 case,
2711	; it can be removed (and use the above case for n>1)		3324	; it can be removed (and use the above case for n>1)
2712	; and the code still works, except a little slower		3325	; and the code still works, except a little slower
2713	(is n 2)		3326	(is n 2)
2714	(with (x (car lst) y (cadr lst) p lst)		3327	(with (x (car lst) y (cadr lst) p lst)
2715	(= lst (cddr lst))		3328	(= lst (cddr lst))
2716	(when (less? y x) (scar p y) (scar (cdr p) x))		3329	(when (less? y x) (scar p y) (scar (cdr p) x))
2717	(scdr (cdr p) nil)		3330	(scdr (cdr p) nil)
2718	p)		3331	p)
2719	(is n 1)		3332	(is n 1)
2720	(with (p lst)		3333	(with (p lst)
2721	(= lst (cdr lst))		3334	(= lst (cdr lst))
2722	(scdr p nil)		3335	(scdr p nil)
2723	p)		3336	p)
2724	nil))		3337	nil))
2725	n))))		3338	n))))
2726			3339
2727	; Also by Eli.		3340	; Also by Eli.
2728			3341
2729	(def merge (less? x y)		3342	(def merge (less? x y)
2730	(if (no x) y		3343	(if (no x) y
2731	(no y) x		3344	(no y) x
2732	(let lup nil		3345	(let lup nil
2733	(set lup	<>	3346	(assign lup
2734	(fn (r x y r-x?) ; r-x? for optimization -- is r connected to x?		3347	(fn (r x y r-x?) ; r-x? for optimization -- is r connected to x?
2735	(if (less? (car y) (car x))		3348	(if (less? (car y) (car x))
2736	(do (if r-x? (scdr r y))		3349	(do (if r-x? (scdr r y))
2737	(if (cdr y) (lup y x (cdr y) nil) (scdr y x)))		3350	(if (cdr y) (lup y x (cdr y) nil) (scdr y x)))
2738	; (car x) <= (car y)		3351	; (car x) <= (car y)
2739	(do (if (no r-x?) (scdr r x))		3352	(do (if (no r-x?) (scdr r x))
2740	(if (cdr x) (lup x (cdr x) y t) (scdr x y))))))		3353	(if (cdr x) (lup x (cdr x) y t) (scdr x y))))))
2741	(if (less? (car y) (car x))	=	3354	(if (less? (car y) (car x))
2742	(do (if (cdr y) (lup y x (cdr y) nil) (scdr y x))		3355	(do (if (cdr y) (lup y x (cdr y) nil) (scdr y x))
2743	y)		3356	y)
2744	; (car x) <= (car y)		3357	; (car x) <= (car y)
2745	(do (if (cdr x) (lup x (cdr x) y t) (scdr x y))		3358	(do (if (cdr x) (lup x (cdr x) y t) (scdr x y))
2746	x)))))		3359	x)))))
2747			3360
2748	(def bestn (n f seq)		3361	(def bestn (n f seq)
2749	(firstn n (sort f seq)))		3362	(firstn n (sort f seq)))
2750			3363
2751	(def split (seq pos)		3364	(def split (seq pos)
2752	(withs (mid (nthcdr (- pos 1) seq)	<>
2753	s2 (cdr mid))
2754	(nil! (cdr mid))
2755	(list seq s2)))		3365	(list (cut seq 0 pos) (cut seq pos)))
2756		=	3366
2757	(mac time (expr)		3367	(mac time (expr)
2758	(w/uniq (t1 t2)		3368	(w/uniq (t1 t2)
2759	`(let ,t1 (msec)		3369	`(let ,t1 (msec)
2760	(do1 ,expr		3370	(do1 ,expr
2761	(let ,t2 (msec)		3371	(let ,t2 (msec)
2762	(prn "time: " (- ,t2 ,t1) " msec."))))))		3372	(prn "time: " (- ,t2 ,t1) " msec."))))))
2763			3373
2764	(mac jtime (expr)		3374	(mac jtime (expr)
2765	`(do1 'ok (time ,expr)))		3375	`(do1 'ok (time ,expr)))
2766			3376
2767	(mac time10 (expr)		3377	(mac time10 (expr)
2768	`(time (repeat 10 ,expr)))		3378	`(time (repeat 10 ,expr)))
2769			3379
		-+	3380	(def union (f xs ys)
			3381	(+ xs (rem (fn (y) (some [f _ y] xs))
			3382	ys)))
			3383
2770	(= templates* (table))	=	3384	(= templates* (table))
2771			3385
2772	(def maps (fn . args)	+-
2773	(apply join (apply map fn args)))
2774
2775	(mac deftem (tem . fields)	=	3386	(mac deftem (tem . fields)
2776	(withs (name (carif tem) includes (if (acons tem) (cdr tem)))		3387	(withs (name (carif tem) includes (if (acons tem) (cdr tem)))
2777	`(= (templates* ',name)		3388	`(= (templates* ',name)
2778	(+ (maps templates* ',(rev includes))	<>	3389	(+ (mappend templates* ',(rev includes))
2779	(list ,@(map (fn ((k v)) `(list ',k (fn () ,v)))	=	3390	(list ,@(map (fn ((k v)) `(list ',k (fn () ,v)))
2780	(pair fields)))))))		3391	(pair fields)))))))
2781			3392
		-+	3393	(mac addtem (name . fields)
			3394	`(= (templates* ',name)
			3395	(union (fn (x y) (is (car x) (car y)))
			3396	(list ,@(map (fn ((k v)) `(list ',k (fn () ,v)))
			3397	(pair fields)))
			3398	(templates* ',name))))
			3399
2782	(def inst (tem . args)	=	3400	(def inst (tem . args)
2783	(let x (table)		3401	(let x (table)
2784	(each (k v) (templates* tem)	<>	3402	(each (k v) (if (acons tem) tem (templates* tem))
2785	(unless (no v) (= (x k) (v))))	=	3403	(unless (no v) (= (x k) (v))))
2786	(each (k v) (pair args)		3404	(each (k v) (pair args)
2787	(= (x k) v))		3405	(= (x k) v))
2788	x))		3406	x))
2789			3407
2790	; To write something to be read by temread, (write (tablist x))		3408	; To write something to be read by temread, (write (tablist x))
2791			3409
2792	(def temread (tem (o str (stdin)))		3410	(def temread (tem (o str (stdin)))
2793	(templatize tem (read str)))		3411	(templatize tem (read str)))
2794			3412
2795	; Converts alist to inst; ugly; maybe should make this part of coerce.		3413	; Converts alist to inst; ugly; maybe should make this part of coerce.
2796	; Note: discards fields not defined by the template.		3414	; Note: discards fields not defined by the template.
2797			3415
2798	(def templatize (tem raw)		3416	(def templatize (tem raw)
2799	(with (x (inst tem) fields (templates* tem))	<>	3417	(with (x (inst tem) fields (if (acons tem) tem (templates* tem)))
2800	(each (k v) raw	=	3418	(each (k v) raw
2801	(when (assoc k fields)		3419	(when (assoc k fields)
2802	(= (x k) v)))		3420	(= (x k) v)))
2803	x))		3421	x))
2804			3422
2805	(def temload (tem file)		3423	(def temload (tem file)
2806	(w/infile i file (temread tem i)))		3424	(w/infile i file (temread tem i)))
2807			3425
2808	(def temloadall (tem file)		3426	(def temloadall (tem file)
2809	(map (fn (pairs) (templatize tem pairs))		3427	(map (fn (pairs) (templatize tem pairs))
2810	(w/infile in file (readall in))))		3428	(w/infile in file (readall in))))
2811			3429
2812			3430
2813	(def number (n) (in (type n) 'int 'num))		3431	(def number (n) (in (type n) 'int 'num))
2814			3432
		-+	3433	(def since (t1) (- (seconds) t1))
			3434
			3435	(def minutes-since (t1) (/ (since t1) 60))
			3436	(def hours-since (t1) (/ (since t1) 3600))
			3437	(def days-since (t1) (/ (since t1) 86400))
			3438
			3439	; could use a version for fns of 1 arg at least
			3440
2815	(def cache (timef valf)	=	3441	(def cache (timef valf)
2816	(with (cached nil gentime nil)		3442	(with (cached nil gentime nil)
2817	(fn ()		3443	(fn ()
2818	(unless (and cached (< (- (seconds) gentime) (timef)))	<>	3444	(unless (and cached (< (since gentime) (timef)))
2819	(= cached (valf)	=	3445	(= cached (valf)
2820	gentime (seconds)))		3446	gentime (seconds)))
2821	cached)))		3447	cached)))
2822			3448
		-+	3449	(mac defcache (name lasts . body)
			3450	`(safeset ,name (cache (fn () ,lasts)
			3451	(fn () ,@body))))
			3452
2823	(mac errsafe (expr)	=	3453	(mac errsafe (expr)
2824	`(on-err (fn (c) nil)		3454	`(on-err (fn (c) nil)
2825	(fn () ,expr)))		3455	(fn () ,expr)))
2826			3456
2827	(def saferead (arg) (errsafe (read arg)))	<>	3457	(def saferead (arg) (errsafe:read arg))
2828		=	3458
2829	(def safe-load-table (filename)		3459	(def safe-load-table (filename)
2830	(or (errsafe (load-table filename))	<>	3460	(or (errsafe:load-table filename)
2831	(table)))	=	3461	(table)))
2832			3462
2833	(def ensure-dir (path)		3463	(def ensure-dir (path)
2834	(unless (dir-exists path)		3464	(unless (dir-exists path)
2835	(system (string "mkdir " path))))	<>	3465	(system (string "mkdir -p " path))))
2836		=	3466
2837	(def date ((o time (seconds)))	<>	3467	(def date ((o s (seconds)))
2838	(let val (tostring (system (string "date -u -r " time " \"+%Y-%m-%d\"")))		3468	(rev (nthcdr 3 (timedate s))))
2839	(subseq val 0 (- (len val) 1))))
2840		=	3469
2841	(def since (t1) (- (seconds) t1))	<>	3470	(def datestring ((o s (seconds)))
			3471	(let (y m d) (date s)
			3472	(string y "-" (if (< m 10) "0") m "-" (if (< d 10) "0") d)))
2842		=	3473
2843	(def count (test x)		3474	(def count (test x)
2844	(with (n 0 testf (testify test))		3475	(with (n 0 testf (testify test))
2845	(each elt x		3476	(each elt x
2846	(if (testf elt) (++ n)))		3477	(if (testf elt) (++ n)))
2847	n))		3478	n))
2848			3479
2849	(def ellipsize (str (o limit 80))		3480	(def ellipsize (str (o limit 80))
2850	(if (<= (len str) limit)		3481	(if (<= (len str) limit)
2851	str		3482	str
2852	(+ (subseq str 0 limit) "...")))	<>	3483	(+ (cut str 0 limit) "...")))
2853		=	3484
		<>	3485	(def rand-elt (seq)
2854	(def random-elt (seq) (seq (rand (len seq))))		3486	(seq (rand (len seq))))
2855		=	3487
2856	(mac until (test . body)		3488	(mac until (test . body)
2857	`(while (no ,test) ,@body))		3489	`(while (no ,test) ,@body))
2858			3490
2859	(def before (x y seq (o i 0))		3491	(def before (x y seq (o i 0))
2860	(with (xp (pos x seq i) yp (pos y seq i))		3492	(with (xp (pos x seq i) yp (pos y seq i))
2861	(and xp (or (no yp) (< xp yp)))))		3493	(and xp (or (no yp) (< xp yp)))))
2862			3494
2863	(def orf fns		3495	(def orf fns
		<>	3496	(fn args
2864	(fn (x) (some [_ x] fns)))		3497	((afn (fs)
			3498	(and fs (or (apply (car fs) args) (self (cdr fs)))))
			3499	fns)))
2865		=	3500
2866	(def andf fns		3501	(def andf fns
		<>	3502	(fn args
2867	(fn (x) (all [_ x] fns)))		3503	((afn (fs)
			3504	(if (no fs) t
			3505	(no (cdr fs)) (apply (car fs) args)
			3506	(and (apply (car fs) args) (self (cdr fs)))))
			3507	fns)))
2868		=	3508
2869	(def atend (i s)		3509	(def atend (i s)
2870	(>= i (- (len s) 1)))	<>	3510	(> i (- (len s) 2)))
2871		=	3511
2872	(def multiple (x y)		3512	(def multiple (x y)
2873	(is 0 (mod x y)))		3513	(is 0 (mod x y)))
2874			3514
2875	(mac nor args `(no (or ,@args)))		3515	(mac nor args `(no (or ,@args)))
2876			3516
2877	; Consider making the default sort fn take compare's two args (when do		3517	; Consider making the default sort fn take compare's two args (when do
2878	; you ever have to sort mere lists of numbers?) and rename current sort		3518	; you ever have to sort mere lists of numbers?) and rename current sort
2879	; as prim-sort or something.		3519	; as prim-sort or something.
2880			3520
2881	; Could simply modify e.g. > so that (> len) returned the same thing		3521	; Could simply modify e.g. > so that (> len) returned the same thing
2882	; as (compare > len).		3522	; as (compare > len).
2883			3523
2884	(def compare (comparer scorer)		3524	(def compare (comparer scorer)
2885	(fn (x y) (comparer (scorer x) (scorer y))))		3525	(fn (x y) (comparer (scorer x) (scorer y))))
2886			3526
2887	; Cleaner thus, but may only ever need in 2 arg case.		3527	; Cleaner thus, but may only ever need in 2 arg case.
2888			3528
2889	;(def compare (comparer scorer)		3529	;(def compare (comparer scorer)
2890	; (fn args (apply comparer map scorer args)))		3530	; (fn args (apply comparer map scorer args)))
2891			3531
		<>	3532	; (def only (f g . args) (aif (apply g args) (f it)))
			3533
2892	(def only (f g . args)		3534	(def only (f)
2893	(aif (apply g args) (f it)))		3535	(fn args (if (car args) (apply f args))))
2894		=	3536
2895	(mac conswhen (f x y)		3537	(mac conswhen (f x y)
2896	(w/uniq (gf gx)		3538	(w/uniq (gf gx)
2897	`(with (,gf ,f ,gx ,x)		3539	`(with (,gf ,f ,gx ,x)
2898	(if (,gf ,gx) (cons ,gx ,y) ,y))))		3540	(if (,gf ,gx) (cons ,gx ,y) ,y))))
2899			3541
2900	; Could rename this get, but don't unless it's frequently used.	<>	3542	; Could combine with firstn if put f arg last, default to (fn (x) t).
2901		=	3543
2902	(def firstn-that (n f xs)	<>	3544	(def retrieve (n f xs)
			3545	(if (no n) (keep f xs)
2903	(if (or (<= n 0) (no xs))		3546	(or (<= n 0) (no xs)) nil
2904	nil
2905	(f (car xs))
2906	(cons (car xs) (firstn-that (- n 1) f (cdr xs)))		3547	(f (car xs)) (cons (car xs) (retrieve (- n 1) f (cdr xs)))
2907	(firstn-that n f (cdr xs))))		3548	(retrieve n f (cdr xs))))
2908		=	3549
2909	(def dedup (xs)		3550	(def dedup (xs)
2910	(with (h (table) acc nil)		3551	(with (h (table) acc nil)
2911	(each x xs		3552	(each x xs
2912	(unless (h x)		3553	(unless (h x)
2913	(push x acc)		3554	(push x acc)
2914	(t! (h x))))	<>	3555	(set (h x))))
2915	(rev acc)))	=	3556	(rev acc)))
2916			3557
2917	(def single (x) (and (acons x) (no (cdr x))))		3558	(def single (x) (and (acons x) (no (cdr x))))
2918			3559
2919	(def plural (n str)	+-
2920	(if (or (is n 1) (single n))
2921	str
2922	(string str "s")))
2923
2924	(def intersperse (x ys)	=	3560	(def intersperse (x ys)
2925	(cons (car ys)	<>	3561	(and ys (cons (car ys)
2926	(mappend [list x _] (cdr ys))))		3562	(mappend [list x _] (cdr ys)))))
2927		=	3563
2928	(def counts (seq (o c (table)))		3564	(def counts (seq (o c (table)))
2929	(if (no seq)		3565	(if (no seq)
2930	c		3566	c
2931	(do (zap [if _ (+ _ 1) 1] (c (car seq)))	<>	3567	(do (++ (c (car seq) 0))
2932	(counts (cdr seq) c))))	=	3568	(counts (cdr seq) c))))
2933			3569
2934	(def commonest (seq)		3570	(def commonest (seq)
2935	(with (winner nil n 0)		3571	(with (winner nil n 0)
2936	(ontable k v (counts seq)	<>	3572	(each (k v) (counts seq)
2937	(when (> v n) (= winner k n v)))	=	3573	(when (> v n) (= winner k n v)))
2938	(list winner n)))		3574	(list winner n)))
2939		+-
2940	(def splitn (n xs)
2941	(let acc nil
2942	((afn (n xs)
2943	(if (or (no xs) (<= n 0))
2944	(list (rev acc) xs)
2945	(do (push (car xs) acc)
2946	(self (- n 1) (cdr xs)))))
2947	n xs)))
2948		=	3575
2949	(def reduce (f xs)		3576	(def reduce (f xs)
2950	(if (cddr xs)		3577	(if (cddr xs)
2951	(reduce f (cons (f (car xs) (cadr xs)) (cddr xs)))		3578	(reduce f (cons (f (car xs) (cadr xs)) (cddr xs)))
2952	(apply f xs)))		3579	(apply f xs)))
2953			3580
2954	(def rreduce (f xs)		3581	(def rreduce (f xs)
2955	(if (cddr xs)		3582	(if (cddr xs)
2956	(f (car xs) (rreduce f (cdr xs)))		3583	(f (car xs) (rreduce f (cdr xs)))
2957	(apply f xs)))		3584	(apply f xs)))
2958			3585
2959	(let argsym (uniq)		3586	(let argsym (uniq)
2960			3587
2961	(def parse-format (str)		3588	(def parse-format (str)
2962	(rev (accum a	<>	3589	(accum a
2963	(with (chars nil i -1)		3590	(with (chars nil i -1)
2964	(w/instring s str		3591	(w/instring s str
2965	(whilet c (readc s)		3592	(whilet c (readc s)
2966	(case c		3593	(case c
2967	#\# (do (a (coerce (rev chars) 'string))		3594	#\# (do (a (coerce (rev chars) 'string))
2968	(nil! chars)		3595	(wipe chars)
2969	(a (read s)))		3596	(a (read s)))
2970	#\~ (do (a (coerce (rev chars) 'string))		3597	#\~ (do (a (coerce (rev chars) 'string))
2971	(nil! chars)		3598	(wipe chars)
2972	(readc s)		3599	(readc s)
2973	(a (list argsym (++ i))))		3600	(a (list argsym (++ i))))
2974	(push c chars))))		3601	(push c chars))))
2975	(when chars		3602	(when chars
2976	(a (coerce (rev chars) 'string)))))))		3603	(a (coerce (rev chars) 'string))))))
2977		=	3604
2978	(mac prf (str . args)		3605	(mac prf (str . args)
2979	`(let ,argsym (list ,@args)		3606	`(let ,argsym (list ,@args)
2980	(pr ,@(parse-format str))))		3607	(pr ,@(parse-format str))))
2981	)		3608	)
2982			3609
2983	(def load (file)		3610	(def load (file)
2984	(w/infile f file		3611	(w/infile f file
		<>	3612	(w/uniq eof
2985	(whilet e (read f)		3613	(whiler e (read f eof) eof
2986	(eval e))))		3614	(eval e)))))
2987		=	3615
2988	(def positive (x)		3616	(def positive (x)
2989	(and (number x) (> x 0)))		3617	(and (number x) (> x 0)))
2990			3618
2991	(mac w/table (var . body)		3619	(mac w/table (var . body)
2992	`(let ,var (table) ,@body ,var))		3620	`(let ,var (table) ,@body ,var))
2993			3621
2994	(def ero args	<>	3622	(def ero args
			3623	(w/stdout (stderr)
2995	(each a args		3624	(each a args
2996	(write a (stderr))		3625	(write a)
2997	(writec #\space (stderr))))		3626	(writec #\space))
			3627	(writec #\newline))
			3628	(car args))
2998		=	3629
2999	(def queue () (list nil nil 0))		3630	(def queue () (list nil nil 0))
3000			3631
3001	; Despite call to atomic, once had some sign this wasn't thread-safe.		3632	; Despite call to atomic, once had some sign this wasn't thread-safe.
		-+	3633	; Keep an eye on it.
3002		=	3634
3003	(def enq (obj q)		3635	(def enq (obj q)
3004	(atomic		3636	(atomic
3005	(++ (q 2))		3637	(++ (q 2))
3006	(if (no (car q))		3638	(if (no (car q))
3007	(= (cadr q) (= (car q) (list obj)))		3639	(= (cadr q) (= (car q) (list obj)))
3008	(= (cdr (cadr q)) (list obj)		3640	(= (cdr (cadr q)) (list obj)
3009	(cadr q) (cdr (cadr q))))		3641	(cadr q) (cdr (cadr q))))
3010	(car q)))		3642	(car q)))
3011			3643
3012	(def deq (q)		3644	(def deq (q)
3013	(atomic (unless (is (q 2) 0) (-- (q 2)))		3645	(atomic (unless (is (q 2) 0) (-- (q 2)))
3014	(pop (car q))))		3646	(pop (car q))))
3015			3647
3016	; Should redef len to do this, and make queues lists annotated queue.		3648	; Should redef len to do this, and make queues lists annotated queue.
3017			3649
3018	(def qlen (q) (q 2))		3650	(def qlen (q) (q 2))
3019			3651
3020	(def qlist (q) (car q))		3652	(def qlist (q) (car q))
3021			3653
3022	(def enq-limit (val q (o limit 1000))		3654	(def enq-limit (val q (o limit 1000))
3023	(atomic		3655	(atomic
3024	(unless (< (qlen q) limit)		3656	(unless (< (qlen q) limit)
3025	(deq q))		3657	(deq q))
3026	(enq val q)))		3658	(enq val q)))
3027			3659
3028	(def median (ns)		3660	(def median (ns)
3029	((sort > ns) (truncate (/ (len ns) 2))))	<>	3661	((sort > ns) (trunc (/ (len ns) 2))))
3030		=	3662
3031	(mac noisy-each (n var val . body)		3663	(mac noisy-each (n var val . body)
3032	(w/uniq (gn gc)		3664	(w/uniq (gn gc)
3033	`(with (,gn ,n ,gc 0)		3665	`(with (,gn ,n ,gc 0)
3034	(each ,var ,val		3666	(each ,var ,val
3035	(when (multiple (++ ,gc) ,gn)		3667	(when (multiple (++ ,gc) ,gn)
3036	(pr ".")		3668	(pr ".")
3037	;(flushout)	<>	3669	(flushout)
3038	)	=	3670	)
3039	,@body)		3671	,@body)
3040	(prn)		3672	(prn)
3041	;(flushout)	<>	3673	(flushout))))
3042	)))
3043		=	3674
3044	(mac point (name . body)		3675	(mac point (name . body)
3045	(w/uniq g	<>	3676	(w/uniq (g p)
3046	`(ccc (fn (,g)	=	3677	`(ccc (fn (,g)
3047	(let ,name [,g _]	<>	3678	(let ,name (fn ((o ,p)) (,g ,p))
3048	,@body)))))	=	3679	,@body)))))
3049			3680
3050	(mac catch body		3681	(mac catch body
3051	`(point throw ,@body))		3682	`(point throw ,@body))
3052			3683
3053	(def downcase (x)		3684	(def downcase (x)
3054	(let downc (fn (c)		3685	(let downc (fn (c)
3055	(let n (coerce c 'int)		3686	(let n (coerce c 'int)
3056	(if (or (< 64 n 91) (< 191 n 215) (< 215 n 223))		3687	(if (or (< 64 n 91) (< 191 n 215) (< 215 n 223))
3057	(coerce (+ n 32) 'char)		3688	(coerce (+ n 32) 'char)
3058	c)))		3689	c)))
3059	(case (type x)		3690	(case (type x)
3060	string (map downc x)		3691	string (map downc x)
3061	char (downc x)		3692	char (downc x)
3062	sym (sym (map downc (coerce x 'string)))		3693	sym (sym (map downc (coerce x 'string)))
3063	(err "Can't downcase" x))))		3694	(err "Can't downcase" x))))
3064			3695
3065	(def upcase (x)		3696	(def upcase (x)
3066	(let upc (fn (c)		3697	(let upc (fn (c)
3067	(let n (coerce c 'int)		3698	(let n (coerce c 'int)
3068	(if (or (< 96 n 123) (< 223 n 247) (< 247 n 255))		3699	(if (or (< 96 n 123) (< 223 n 247) (< 247 n 255))
3069	(coerce (- n 32) 'char)		3700	(coerce (- n 32) 'char)
3070	c)))		3701	c)))
3071	(case (type x)		3702	(case (type x)
3072	string (map upc x)		3703	string (map upc x)
3073	char (upc x)		3704	char (upc x)
3074	sym (sym (map upc (coerce x 'string)))		3705	sym (sym (map upc (coerce x 'string)))
3075	(err "Can't upcase" x))))		3706	(err "Can't upcase" x))))
3076			3707
		-+	3708	(def inc (x (o n 1))
			3709	(coerce (+ (coerce x 'int) n) (type x)))
			3710
3077	(def range (start end)	=	3711	(def range (start end)
3078	(if (> start end)		3712	(if (> start end)
3079	nil		3713	nil
3080	(cons start (range (+ start 1) end))))	<>	3714	(cons start (range (inc start) end))))
3081		=	3715
3082	(def mismatch (s1 s2)		3716	(def mismatch (s1 s2)
3083	(catch		3717	(catch
3084	(on c s1		3718	(on c s1
3085	(when (isnt c (s2 index))		3719	(when (isnt c (s2 index))
3086	(throw index)))))		3720	(throw index)))))
3087			3721
3088	(def memtable (ks)		3722	(def memtable (ks)
3089	(let h (table)		3723	(let h (table)
3090	(each k ks (t! (h k)))	<>	3724	(each k ks (set (h k)))
3091	h))	=	3725	h))
3092			3726
3093	(= bar* " \| ")		3727	(= bar* " \| ")
3094			3728
3095	(mac w/bars body		3729	(mac w/bars body
3096	(w/uniq (out needbars)		3730	(w/uniq (out needbars)
3097	`(let ,needbars nil		3731	`(let ,needbars nil
3098	(do ,@(map (fn (e)		3732	(do ,@(map (fn (e)
3099	`(let ,out (tostring ,e)		3733	`(let ,out (tostring ,e)
3100	(unless (is ,out "")		3734	(unless (is ,out "")
3101	(if ,needbars		3735	(if ,needbars
3102	(pr bar* ,out)		3736	(pr bar* ,out)
3103	(do (t! ,needbars)	<>	3737	(do (set ,needbars)
3104	(pr ,out))))))	=	3738	(pr ,out))))))
3105	body)))))		3739	body)))))
3106			3740
		-+	3741	(def len< (x n) (< (len x) n))
3107		=	3742
		<>	3743	(def len> (x n) (> (len x) n))
3108	; Lower priority ideas		3744
			3745	(mac thread body
			3746	`(new-thread (fn () ,@body)))
3109		=	3747
		-+	3748	(mac trav (x . fs)
			3749	(w/uniq g
			3750	`((afn (,g)
			3751	(when ,g
			3752	,@(map [list _ g] fs)))
			3753	,x)))
			3754
			3755	(mac or= (place expr)
			3756	(let (binds val setter) (setforms place)
			3757	`(atwiths ,binds
			3758	(or ,val (,setter ,expr)))))
			3759
			3760	(= hooks* (table))
			3761
			3762	(def hook (name . args)
			3763	(aif (hooks* name) (apply it args)))
			3764
			3765	(mac defhook (name . rest)
			3766	`(= (hooks* ',name) (fn ,@rest)))
			3767
			3768	(mac out (expr) `(pr ,(tostring (eval expr))))
			3769
			3770	; if renamed this would be more natural for (map [_ user] pagefns*)
			3771
			3772	(def get (index) [_ index])
			3773
			3774	(= savers* (table))
			3775
			3776	(mac fromdisk (var file init load save)
			3777	(w/uniq (gf gv)
			3778	`(unless (bound ',var)
			3779	(do1 (= ,var (iflet ,gf (file-exists ,file)
			3780	(,load ,gf)
			3781	,init))
			3782	(= (savers* ',var) (fn (,gv) (,save ,gv ,file)))))))
			3783
			3784	(mac diskvar (var file)
			3785	`(fromdisk ,var ,file nil readfile1 writefile))
			3786
			3787	(mac disktable (var file)
			3788	`(fromdisk ,var ,file (table) load-table save-table))
			3789
			3790	(mac todisk (var (o expr var))
			3791	`((savers* ',var)
			3792	,(if (is var expr) var `(= ,var ,expr))))
			3793
			3794
			3795	(mac evtil (expr test)
			3796	(w/uniq gv
			3797	`(let ,gv ,expr
			3798	(while (no (,test ,gv))
			3799	(= ,gv ,expr))
			3800	,gv)))
			3801
			3802	(def rand-key (h)
			3803	(if (empty h)
			3804	nil
			3805	(let n (rand (len h))
			3806	(catch
			3807	(each (k v) h
			3808	(when (is (-- n) -1)
			3809	(throw k)))))))
			3810
			3811	(def ratio (test xs)
			3812	(if (empty xs)
			3813	0
			3814	(/ (count test xs) (len xs))))
			3815
			3816
			3817	; any logical reason I can't say (push x (if foo y z)) ?
			3818	; eval would have to always ret 2 things, the val and where it came from
			3819	; idea: implicit tables of tables; setf empty field, becomes table
			3820	; or should setf on a table just take n args?
			3821
			3822	; idea: use constants in functional position for currying?
			3823	; (1 foo) would mean (fn args (apply foo 1 args))
			3824	; another solution would be to declare certain symbols curryable, and
			3825	; if > was, >_10 would mean [> _ 10]
			3826	; or just say what the hell and make _ ssyntax for currying
			3827	; idea: make >10 ssyntax for [> _ 10]
3110	; solution to the "problem" of improper lists: allow any atom as a list	=	3828	; solution to the "problem" of improper lists: allow any atom as a list
3111	; terminator, not just nil. means list recursion should terminate on		3829	; terminator, not just nil. means list recursion should terminate on
3112	; atom rather than nil, (def empty (x) (or (atom x) (is x "")))		3830	; atom rather than nil, (def empty (x) (or (atom x) (is x "")))
3113	; table should be able to take an optional initial-value. handle in sref.		3831	; table should be able to take an optional initial-value. handle in sref.
3114	; warn about code of form (if (= )) -- probably mean is		3832	; warn about code of form (if (= )) -- probably mean is
3115	; warn when a fn has a parm that's already defined as a macro.		3833	; warn when a fn has a parm that's already defined as a macro.
3116	; (def foo (after) (after))		3834	; (def foo (after) (after))
3117	; idea: a fn (nothing) that returns a special gensym which is ignored		3835	; idea: a fn (nothing) that returns a special gensym which is ignored
3118	; by map, so can use map in cases when don't want all the vals		3836	; by map, so can use map in cases when don't want all the vals
3119	; idea: anaph macro so instead of (aand x y) say (anaph and x y)		3837	; idea: anaph macro so instead of (aand x y) say (anaph and x y)
3120	; idea: foo.bar!baz as an abbrev for (foo bar 'baz)		3838	; idea: foo.bar!baz as an abbrev for (foo bar 'baz)
		-+	3839	; or something a bit more semantic?
3121	; could uniq be (def uniq () (annotate 'symbol (list 'u))) again?	=	3840	; could uniq be (def uniq () (annotate 'symbol (list 'u))) again?
3122	; idea: use x- for (car x) and -x for (cdr x) (but what about math -?)		3841	; idea: use x- for (car x) and -x for (cdr x) (but what about math -?)
3123	; idea: get rid of strings and just use symbols		3842	; idea: get rid of strings and just use symbols
3124	; could a string be (#\a #\b . "") ?		3843	; could a string be (#\a #\b . "") ?
3125	; better err msg when , outside of a bq		3844	; better err msg when , outside of a bq
3126	; idea: parameter (p foo) means in body foo is (pair arg)		3845	; idea: parameter (p foo) means in body foo is (pair arg)
3127	; idea: make ('string x) equiv to (coerce x 'string) ? or isa?		3846	; idea: make ('string x) equiv to (coerce x 'string) ? or isa?
3128	; quoted atoms in car valuable unused semantic space		3847	; quoted atoms in car valuable unused semantic space
		-+	3848	; idea: if (defun foo (x y) ...), make (foo 1) return (fn (y) (foo 1 y))
			3849	; probably would lead to lots of errors when call with missing args
			3850	; but would be really dense with . notation, (foo.1 2)
			3851	; or use special ssyntax for currying: (foo@1 2)
			3852	; remember, can also double; could use foo::bar to mean something
			3853	; wild idea: inline defs for repetitive code
			3854	; same args as fn you're in
			3855	; variant of compose where first fn only applied to first arg?
			3856	; (> (len x) y) means (>+len x y)
			3857	; use ssyntax underscore for a var?
			3858	; foo_bar means [foo _ bar]
			3859	; what does foo:_:bar mean?
			3860	; matchcase
			3861	; idea: atable that binds it to table, assumes input is a list
			3862	; crazy that finding the top 100 nos takes so long:
			3863	; (let bb (n-of 1000 (rand 50)) (time10 (bestn 100 > bb)))
			3864	; time: 2237 msec. -> now down to 850 msec
3129		=	3865
3130			3866
3131	./as.scm		3867	./as.scm
3132	; mzscheme -m -f as.scm		3868	; mzscheme -m -f as.scm
3133	; (tl)		3869	; (tl)
3134	; (asv)		3870	; (asv)
3135	; http://localhost:8080		3871	; http://localhost:8080
3136			3872
3137	(require mzscheme) ; promise we won't redefine mzscheme bindings		3873	(require mzscheme) ; promise we won't redefine mzscheme bindings
3138			3874
3139	(load "ac.scm")	<>	3875	(require "ac.scm")
3140	(require "brackets.scm")	=	3876	(require "brackets.scm")
3141	(use-bracket-readtable)		3877	(use-bracket-readtable)
3142			3878
3143	(aload "arc.arc")		3879	(aload "arc.arc")
3144	(aload "libs.arc")		3880	(aload "libs.arc")
3145			3881
3146	(tl)		3882	(tl)
3147			3883
3148			3884
3149	./blog.arc		3885	./blog.arc
3150	; Blog tool example. 20 Jan 08.	<>	3886	; Blog tool example. 20 Jan 08, rev 21 May 09.
3151		=	3887
3152	; To run:		3888	; To run:
3153	; arc> (load "blog.arc")		3889	; arc> (load "blog.arc")
3154	; arc> (bsv)		3890	; arc> (bsv)
3155	; go to http://localhost:8080/blog		3891	; go to http://localhost:8080/blog
3156			3892
3157	(= postdir* "arc/posts/" maxid* 0 posts* (table))		3893	(= postdir* "arc/posts/" maxid* 0 posts* (table))
3158			3894
3159	(= blogtitle* "A Blog")		3895	(= blogtitle* "A Blog")
3160			3896
3161	(deftem post	<>	3897	(deftem post id nil title nil text nil)
3162	id nil
3163	title nil
3164	text nil)
3165		=	3898
3166	(def load-posts ()		3899	(def load-posts ()
3167	(each id (map [coerce _ 'int] (dir postdir*))	<>	3900	(each id (map int (dir postdir*))
3168	(= maxid* (max maxid* id)	=	3901	(= maxid* (max maxid* id)
3169	(posts* id) (temload 'post (string postdir* id)))))		3902	(posts* id) (temload 'post (string postdir* id)))))
3170			3903
3171	(def save-post (p)	<>
3172	(save-table p (string postdir* (p 'id))))		3904	(def save-post (p) (save-table p (string postdir* p!id)))
3173		=	3905
3174	(def post (id) (posts* (errsafe (coerce id 'int))))	<>	3906	(def post (id) (posts* (errsafe:int id)))
3175		=	3907
3176	(mac blogpage body		3908	(mac blogpage body
3177	`(whitepage		3909	`(whitepage
3178	(center		3910	(center
3179	(widtable 600		3911	(widtable 600
3180	(tag b (link blogtitle* "blog"))		3912	(tag b (link blogtitle* "blog"))
3181	(br 3)		3913	(br 3)
3182	,@body		3914	,@body
3183	(br 3)		3915	(br 3)
3184	(w/bars (link "archive")		3916	(w/bars (link "archive")
3185	(link "new post" "newpost"))))))		3917	(link "new post" "newpost"))))))
3186			3918
		<>	3919	(defop viewpost req (blogop post-page req))
3187	(defop viewpost req		3920
			3921	(def blogop (f req)
3188	(aif (post (arg req "id"))	=	3922	(aif (post (arg req "id"))
3189	(post-page (get-user req) it)	<>	3923	(f (get-user req) it)
3190	(notfound)))		3924	(blogpage (pr "No such post."))))
3191		=	3925
3192	(def permalink (p) (string "viewpost?id=" (p 'id)))	<>	3926	(def permalink (p) (string "viewpost?id=" p!id))
3193		=	3927
3194	(def post-page (user p) (blogpage (display-post user p)))		3928	(def post-page (user p) (blogpage (display-post user p)))
3195			3929
3196	(def display-post (user p)		3930	(def display-post (user p)
3197	(tag b (link (p 'title) (permalink p)))	<>	3931	(tag b (link p!title (permalink p)))
3198	(when user	=	3932	(when user
3199	(sp)		3933	(sp)
3200	(link "[edit]" (string "editpost?id=" (p 'id))))	<>	3934	(link "[edit]" (string "editpost?id=" p!id)))
3201	(br2)	=	3935	(br2)
3202	(pr (p 'text)))	<>	3936	(pr p!text))
3203		=	3937
3204	(def notfound ()	+-
3205	(blogpage (pr "No such post.")))
3206
3207	(defopl newpost req	=	3938	(defopl newpost req
3208	(whitepage		3939	(whitepage
3209	(aform (fn (req)	<>
3210	(let user (get-user req)		3940	(aform [let u (get-user _)
3211	(post-page user
3212	(addpost user (arg req "t") (arg req "b")))))		3941	(post-page u (addpost u (arg _ "t") (arg _ "b")))]
3213	(tab
3214	(row "title" (input "t" "" 60))		3942	(tab (row "title" (input "t" "" 60))
3215	(row "text" (textarea "b" 10 80))		3943	(row "text" (textarea "b" 10 80))
3216	(row "" (submit))))))		3944	(row "" (submit))))))
3217		=	3945
3218	(def addpost (user title text)		3946	(def addpost (user title text)
3219	(let p (inst 'post 'id (++ maxid*) 'title title 'text text)		3947	(let p (inst 'post 'id (++ maxid*) 'title title 'text text)
3220	(save-post p)		3948	(save-post p)
3221	(= (posts* (p 'id)) p)))	<>	3949	(= (posts* p!id) p)))
3222		=	3950
3223	(defopl editpost req	<>
3224	(aif (post (arg req "id"))
3225	(edit-page (get-user req) it)		3951	(defopl editpost req (blogop edit-page req))
3226	(notfound)))
3227		=	3952
3228	(def edit-page (user p)		3953	(def edit-page (user p)
3229	(whitepage		3954	(whitepage
3230	(vars-form user		3955	(vars-form user
3231	`((string title ,(p 'title) t t)	<>	3956	`((string title ,p!title t t) (text text ,p!text t t))
3232	(text text ,(p 'text) t t))
3233	(fn (name val) (= (p name) val))	=	3957	(fn (name val) (= (p name) val))
3234	(fn () (save-post p)		3958	(fn () (save-post p)
3235	(post-page user p)))))		3959	(post-page user p)))))
3236			3960
3237	(defop archive req		3961	(defop archive req
3238	(blogpage		3962	(blogpage
3239	(tag ul		3963	(tag ul
3240	(each p (map post (rev (range 1 maxid*)))		3964	(each p (map post (rev (range 1 maxid*)))
3241	(tag li (link (p 'title) (permalink p)))))))	<>	3965	(tag li (link p!title (permalink p)))))))
3242		=	3966
3243	(defop blog req		3967	(defop blog req
3244	(let user (get-user req)		3968	(let user (get-user req)
3245	(blogpage		3969	(blogpage
3246	(for i 0 4		3970	(for i 0 4
3247	(awhen (posts* (- maxid* i))		3971	(awhen (posts* (- maxid* i))
3248	(display-post user it)		3972	(display-post user it)
3249	(br 3))))))		3973	(br 3))))))
3250			3974
3251	(def bsv ()		3975	(def bsv ()
3252	(ensure-dir postdir*)		3976	(ensure-dir postdir*)
3253	(load-posts)		3977	(load-posts)
3254	(asv))		3978	(asv))
3255			3979
3256			3980
3257			3981
3258	./brackets.scm		3982	./brackets.scm
3259	; From Eli Barzilay, eli@barzilay.org		3983	; From Eli Barzilay, eli@barzilay.org
3260			3984
3261	;> (require "brackets.scm")		3985	;> (require "brackets.scm")
3262	;> (use-bracket-readtable)		3986	;> (use-bracket-readtable)
3263	;> ([+ _ 1] 10)		3987	;> ([+ _ 1] 10)
3264	;11		3988	;11
3265			3989
3266	(module brackets mzscheme		3990	(module brackets mzscheme
3267			3991
3268	; main reader function for []s		3992	; main reader function for []s
3269	; recursive read starts with default readtable's [ parser,		3993	; recursive read starts with default readtable's [ parser,
3270	; but nested reads still use the curent readtable:		3994	; but nested reads still use the curent readtable:
3271			3995
3272	(define (read-square-brackets ch port src line col pos)		3996	(define (read-square-brackets ch port src line col pos)
3273	`(fn (_)		3997	`(fn (_)
3274	,(read/recursive port #\[ #f)))		3998	,(read/recursive port #\[ #f)))
3275			3999
3276	; a readtable that is just like the builtin except for []s		4000	; a readtable that is just like the builtin except for []s
3277			4001
3278	(define bracket-readtable		4002	(define bracket-readtable
3279	(make-readtable #f #\[ 'terminating-macro read-square-brackets))		4003	(make-readtable #f #\[ 'terminating-macro read-square-brackets))
3280			4004
3281	; call this to set the global readtable		4005	; call this to set the global readtable
3282			4006
3283	(provide use-bracket-readtable)		4007	(provide use-bracket-readtable)
3284			4008
3285	(define (use-bracket-readtable)		4009	(define (use-bracket-readtable)
3286	(current-readtable bracket-readtable))		4010	(current-readtable bracket-readtable))
3287			4011
3288	; these two implement the required functionality for #reader		4012	; these two implement the required functionality for #reader
3289			4013
3290	;(define (*read inp)		4014	;(define (*read inp)
3291	; (parameterize ((current-readtable bracket-readtable))		4015	; (parameterize ((current-readtable bracket-readtable))
3292	; (read inp)))		4016	; (read inp)))
3293			4017
3294	(define (*read . args)		4018	(define (*read . args)
3295	(parameterize ((current-readtable bracket-readtable))		4019	(parameterize ((current-readtable bracket-readtable))
3296	(read (if (null? args) (current-input-port) (car args)))))		4020	(read (if (null? args) (current-input-port) (car args)))))
3297			4021
3298	(define (*read-syntax src port)		4022	(define (*read-syntax src port)
3299	(parameterize ((current-readtable bracket-readtable))		4023	(parameterize ((current-readtable bracket-readtable))
3300	(read-syntax src port)))		4024	(read-syntax src port)))
3301			4025
3302	; and the need to be provided as `read' and `read-syntax'		4026	; and the need to be provided as `read' and `read-syntax'
3303			4027
3304	(provide (rename read read) (rename read-syntax read-syntax))		4028	(provide (rename read read) (rename read-syntax read-syntax))
3305			4029
3306	)		4030	)
3307			4031
3308	./code.arc		4032	./code.arc
3309	; Code analysis. Spun off 21 Dec 07.		4033	; Code analysis. Spun off 21 Dec 07.
3310			4034
3311	; Ought to do more of this in Arc. One of the biggest advantages		4035	; Ought to do more of this in Arc. One of the biggest advantages
3312	; of Lisp is messing with code.		4036	; of Lisp is messing with code.
3313			4037
3314	(def codelines (file)		4038	(def codelines (file)
3315	(w/infile in file		4039	(w/infile in file
3316	(summing test		4040	(summing test
3317	(whilet line (readline in)		4041	(whilet line (readline in)
3318	(test (aand (pos nonwhite line) (isnt it #\;)))))))	<>	4042	(test (aand (find nonwhite line) (isnt it #\;)))))))
3319		=	4043
3320	(def codeflat (file)		4044	(def codeflat (file)
3321	(len (flat (readall (infile file)))))		4045	(len (flat (readall (infile file)))))
3322			4046
3323	(def codetree (file)		4047	(def codetree (file)
3324	(trav + (fn (x) 1) (readall (infile file))))	<>	4048	(treewise + (fn (x) 1) (readall (infile file))))
3325		=	4049
3326	(def code-density (file)		4050	(def code-density (file)
3327	(/ (codetree file) (codelines file)))		4051	(/ (codetree file) (codelines file)))
3328			4052
3329	(def tokcount (files)		4053	(def tokcount (files)
3330	(let counts (table)		4054	(let counts (table)
3331	(each f files		4055	(each f files
3332	(each token (flat (readall (infile f)))		4056	(each token (flat (readall (infile f)))
3333	(= (counts token)	<>
3334	(+ 1 (or (counts token) 0)))))		4057	(++ (counts token 0))))
3335	counts))	=	4058	counts))
3336			4059
3337	(def common-tokens (files)		4060	(def common-tokens (files)
3338	(let counts (tokcount files)		4061	(let counts (tokcount files)
3339	(let ranking nil		4062	(let ranking nil
3340	(maptable (fn (k v)		4063	(maptable (fn (k v)
3341	(unless (nonop k)		4064	(unless (nonop k)
3342	(insort (compare > cadr) (list k v) ranking)))		4065	(insort (compare > cadr) (list k v) ranking)))
3343	counts)		4066	counts)
3344	ranking)))		4067	ranking)))
3345			4068
3346	(def nonop (x)		4069	(def nonop (x)
3347	(in x 'quote 'unquote 'quasiquote 'unquote-splicing))		4070	(in x 'quote 'unquote 'quasiquote 'unquote-splicing))
3348			4071
3349	(def common-operators (files)		4072	(def common-operators (files)
3350	(keep [and (isa (car _) 'sym) (bound (car _))] (common-tokens files)))		4073	(keep [and (isa (car _) 'sym) (bound (car _))] (common-tokens files)))
3351			4074
3352	(def top40 (xs)		4075	(def top40 (xs)
3353	(map prn (firstn 40 xs))		4076	(map prn (firstn 40 xs))
3354	t)		4077	t)
3355			4078
3356	(def space-eaters (files)		4079	(def space-eaters (files)
3357	(let counts (tokcount files)		4080	(let counts (tokcount files)
3358	(let ranking nil		4081	(let ranking nil
3359	(maptable (fn (k v)		4082	(maptable (fn (k v)
3360	(when (and (isa k 'sym) (bound k))		4083	(when (and (isa k 'sym) (bound k))
3361	(insort (compare > [* (len (coerce (car _) 'string))	<>	4084	(insort (compare > [* (len (string (car _)))
3362	(cadr _)])	=	4085	(cadr _)])
3363	(list k v (* (len (string k)) v))		4086	(list k v (* (len (string k)) v))
3364	ranking)))		4087	ranking)))
3365	counts)		4088	counts)
3366	ranking)))		4089	ranking)))
3367			4090
3368	;(top40 (space-eaters allfiles*))		4091	;(top40 (space-eaters allfiles*))
3369			4092
		-+	4093	(mac flatlen args `(len (flat ',args)))
3370		=	4094
3371	./html.arc		4095	./html.arc
3372	; HTML Utils.		4096	; HTML Utils.
3373			4097
3374			4098
3375	(def color (r g b)		4099	(def color (r g b)
3376	(with (c (table)		4100	(with (c (table)
3377	f (fn (x) (if (< x 0) 0 (> x 255) 255 x)))		4101	f (fn (x) (if (< x 0) 0 (> x 255) 255 x)))
3378	(= (c 'r) (f r) (c 'g) (f g) (c 'b) (f b))		4102	(= (c 'r) (f r) (c 'g) (f g) (c 'b) (f b))
3379	c))		4103	c))
3380			4104
3381	(def dehex (str) (errsafe (coerce str 'int 16)))		4105	(def dehex (str) (errsafe (coerce str 'int 16)))
3382			4106
3383	(defmemo hex>color (str)		4107	(defmemo hex>color (str)
3384	(and (is (len str) 6)		4108	(and (is (len str) 6)
3385	(with (r (dehex (subseq str 0 2))	<>	4109	(with (r (dehex (cut str 0 2))
3386	g (dehex (subseq str 2 4))		4110	g (dehex (cut str 2 4))
3387	b (dehex (subseq str 4 6)))		4111	b (dehex (cut str 4 6)))
3388	(and r g b	=	4112	(and r g b
3389	(color r g b)))))		4113	(color r g b)))))
3390			4114
3391	(defmemo gray (n) (color n n n))		4115	(defmemo gray (n) (color n n n))
3392			4116
3393	(= white (gray 255)		4117	(= white (gray 255)
3394	black (gray 0)		4118	black (gray 0)
3395	linkblue (color 0 0 190))	<>	4119	linkblue (color 0 0 190)
			4120	orange (color 255 102 0)
			4121	darkred (color 180 0 0)
			4122	darkblue (color 0 0 120)
			4123	)
3396		=	4124
3397	(= opmeths* (table))		4125	(= opmeths* (table))
3398			4126
3399	; hack: intern key pair till have implicit tables of tables	<>
3400
3401	(mac opmeth (tag opt)		4127	(mac opmeth args
3402	`(opmeths* (sym (+ (coerce ,tag 'string) "." (coerce ,opt 'string)))))		4128	`(opmeths* (list ,@args)))
3403		=	4129
3404	(mac attribute (tag opt f)		4130	(mac attribute (tag opt f)
3405	; `(= (opmeth ',tag ',opt) ,f)	<>	4131	`(= (opmeths* (list ',tag ',opt)) ,f))
3406	`(= (opmeths* ',(sym (+ (coerce tag 'string) "." (coerce opt 'string))))
3407	,f))
3408		=	4132
3409	(= hexreps (table))		4133	(= hexreps (table))
3410			4134
3411	(for i 0 255 (= (hexreps i)		4135	(for i 0 255 (= (hexreps i)
3412	(let s (coerce i 'string 16)		4136	(let s (coerce i 'string 16)
3413	(if (is (len s) 1) (+ "0" s) s))))		4137	(if (is (len s) 1) (+ "0" s) s))))
3414			4138
3415	(defmemo hexrep (col)		4139	(defmemo hexrep (col)
3416	(+ (hexreps (col 'r)) (hexreps (col 'g)) (hexreps (col 'b))))		4140	(+ (hexreps (col 'r)) (hexreps (col 'g)) (hexreps (col 'b))))
3417			4141
3418	(def opcolor (key val)		4142	(def opcolor (key val)
3419	(w/uniq gv		4143	(w/uniq gv
3420	`(whenlet ,gv ,val		4144	`(whenlet ,gv ,val
3421	(pr " " ',key "=#" (hexrep ,gv)))))	<>	4145	(pr ,(string " " key "=#") (hexrep ,gv)))))
3422		=	4146
3423	(def opstring (key val)		4147	(def opstring (key val)
3424	`(aif ,val (pr " " ',key "=\"" it #\")))	<>	4148	`(aif ,val (pr ,(+ " " key "=\"") it #\")))
3425		=	4149
3426	(def opnum (key val)		4150	(def opnum (key val)
3427	`(aif ,val (pr " " ',key "=" it)))	<>	4151	`(aif ,val (pr ,(+ " " key "=") it)))
3428		=	4152
3429	(def opsym (key val)		4153	(def opsym (key val)
3430	`(pr " " ',key "=" ,val))	<>	4154	`(pr ,(+ " " key "=") ,val))
3431		=	4155
3432	(def opsel (key val)		4156	(def opsel (key val)
3433	`(if ,val (pr " selected")))		4157	`(if ,val (pr " selected")))
3434			4158
		-+	4159	(def opcheck (key val)
			4160	`(if ,val (pr " checked")))
			4161
3435	(def opesc (key val)	=	4162	(def opesc (key val)
3436	`(awhen ,val		4163	`(awhen ,val
3437	(pr " " ',key "=\"")	<>	4164	(pr ,(string " " key "=\""))
3438	(if (isa it 'string) (pr-escaped it) (pr it))	=	4165	(if (isa it 'string) (pr-escaped it) (pr it))
3439	(pr #\")))		4166	(pr #\")))
3440			4167
3441	; need to escape more? =?		4168	; need to escape more? =?
3442			4169
3443	(def pr-escaped (x)		4170	(def pr-escaped (x)
3444	(each c x		4171	(each c x
3445	(pr (case c #\< "<"		4172	(pr (case c #\< "<"
3446	#\> ">"		4173	#\> ">"
3447	#\" """		4174	#\" """
3448	#\& "&"		4175	#\& "&"
3449	c))))		4176	c))))
3450			4177
3451	(attribute a href opstring)		4178	(attribute a href opstring)
3452	(attribute a rel opstring)		4179	(attribute a rel opstring)
3453	(attribute a class opstring)		4180	(attribute a class opstring)
3454	(attribute a id opsym)		4181	(attribute a id opsym)
3455	(attribute a onclick opstring)		4182	(attribute a onclick opstring)
3456	(attribute body alink opcolor)		4183	(attribute body alink opcolor)
3457	(attribute body bgcolor opcolor)		4184	(attribute body bgcolor opcolor)
3458	(attribute body leftmargin opnum)		4185	(attribute body leftmargin opnum)
3459	(attribute body link opcolor)		4186	(attribute body link opcolor)
3460	(attribute body marginheight opnum)		4187	(attribute body marginheight opnum)
3461	(attribute body marginwidth opnum)		4188	(attribute body marginwidth opnum)
3462	(attribute body topmargin opnum)		4189	(attribute body topmargin opnum)
3463	(attribute body vlink opcolor)		4190	(attribute body vlink opcolor)
3464	(attribute font color opcolor)		4191	(attribute font color opcolor)
3465	(attribute font face opstring)		4192	(attribute font face opstring)
3466	(attribute font size opnum)		4193	(attribute font size opnum)
3467	(attribute form action opstring)		4194	(attribute form action opstring)
3468	(attribute form method opsym)		4195	(attribute form method opsym)
3469	(attribute img align opsym)		4196	(attribute img align opsym)
3470	(attribute img border opnum)		4197	(attribute img border opnum)
3471	(attribute img height opnum)		4198	(attribute img height opnum)
3472	(attribute img width opnum)		4199	(attribute img width opnum)
3473	(attribute img vspace opnum)		4200	(attribute img vspace opnum)
3474	(attribute img hspace opnum)		4201	(attribute img hspace opnum)
3475	(attribute img src opstring)		4202	(attribute img src opstring)
3476	(attribute input name opstring)		4203	(attribute input name opstring)
3477	(attribute input size opnum)		4204	(attribute input size opnum)
3478	(attribute input type opsym)		4205	(attribute input type opsym)
3479	(attribute input value opesc)		4206	(attribute input value opesc)
3480	(attribute option selected opsel)	<>	4207	(attribute input checked opcheck)
3481	(attribute select name opstring)	=	4208	(attribute select name opstring)
		-+	4209	(attribute option selected opsel)
3482	(attribute table bgcolor opcolor)	=	4210	(attribute table bgcolor opcolor)
3483	(attribute table border opnum)		4211	(attribute table border opnum)
3484	(attribute table cellpadding opnum)		4212	(attribute table cellpadding opnum)
3485	(attribute table cellspacing opnum)		4213	(attribute table cellspacing opnum)
3486	(attribute table width opstring)		4214	(attribute table width opstring)
3487	(attribute textarea cols opnum)		4215	(attribute textarea cols opnum)
3488	(attribute textarea name opstring)		4216	(attribute textarea name opstring)
3489	(attribute textarea rows opnum)		4217	(attribute textarea rows opnum)
3490	(attribute textarea wrap opsym)		4218	(attribute textarea wrap opsym)
3491	(attribute td align opsym)		4219	(attribute td align opsym)
3492	(attribute td bgcolor opcolor)		4220	(attribute td bgcolor opcolor)
3493	(attribute td colspan opnum)		4221	(attribute td colspan opnum)
3494	(attribute td width opnum)		4222	(attribute td width opnum)
3495	(attribute td valign opsym)		4223	(attribute td valign opsym)
3496	(attribute td class opstring)		4224	(attribute td class opstring)
3497	(attribute tr bgcolor opcolor)		4225	(attribute tr bgcolor opcolor)
3498	(attribute hr color opcolor)		4226	(attribute hr color opcolor)
3499	(attribute span class opstring)		4227	(attribute span class opstring)
3500	(attribute span align opstring)		4228	(attribute span align opstring)
3501	(attribute span id opsym)		4229	(attribute span id opsym)
3502	(attribute rss version opstring)		4230	(attribute rss version opstring)
3503			4231
3504			4232
3505	(mac gentag args (start-tag args))		4233	(mac gentag args (start-tag args))
3506			4234
3507	(mac tag (spec . body)		4235	(mac tag (spec . body)
3508	`(do ,(start-tag spec)		4236	`(do ,(start-tag spec)
3509	,@body		4237	,@body
3510	,(end-tag spec)))		4238	,(end-tag spec)))
3511			4239
3512	(mac tag-if (test spec . body)		4240	(mac tag-if (test spec . body)
3513	`(if ,test		4241	`(if ,test
3514	(tag ,spec ,@body)		4242	(tag ,spec ,@body)
3515	(do ,@body)))		4243	(do ,@body)))
3516			4244
3517	(def start-tag (spec)		4245	(def start-tag (spec)
3518	(if (atom spec)		4246	(if (atom spec)
3519	`(pr "<" ',spec ">")	<>	4247	`(pr ,(string "<" spec ">"))
3520	`(do (pr "<" ',(car spec))
3521	,@(tag-options (car spec) (pair (cdr spec)))		4248	(let opts (tag-options (car spec) (pair (cdr spec)))
			4249	(if (all [isa _ 'string] opts)
			4250	`(pr ,(string "<" (car spec) (apply string opts) ">"))
			4251	`(do (pr ,(string "<" (car spec)))
			4252	,@(map (fn (opt)
			4253	(if (isa opt 'string)
			4254	`(pr ,opt)
			4255	opt))
			4256	opts)
3522	(pr ">"))))		4257	(pr ">"))))))
3523			4258
3524	(def end-tag (spec)	=	4259	(def end-tag (spec)
3525	`(pr "</" ',(carif spec) ">"))	<>	4260	`(pr ,(string "</" (carif spec) ">")))
3526		=	4261
		-+	4262	(def literal (x)
			4263	(case (type x)
			4264	sym (in x nil t)
			4265	cons (caris x 'quote)
			4266	t))
			4267
			4268	; Returns a list whose elements are either strings, which can
			4269	; simply be printed out, or expressions, which when evaluated
			4270	; generate output.
			4271
3527	(def tag-options (spec options)	=	4272	(def tag-options (spec options)
3528	(if (no options)		4273	(if (no options)
3529	'()		4274	'()
3530	(let ((opt val) . rest) options		4275	(let ((opt val) . rest) options
3531	(let meth (if (is opt 'style) opstring (opmeth spec opt))		4276	(let meth (if (is opt 'style) opstring (opmeth spec opt))
3532	(if meth		4277	(if meth
3533	(if val		4278	(if val
		<>	4279	(cons (if (precomputable-tagopt val)
			4280	(tostring (eval (meth opt val)))
3534	(cons (meth opt val)		4281	(meth opt val))
3535	(tag-options spec rest))	=	4282	(tag-options spec rest))
3536	(tag-options spec rest))		4283	(tag-options spec rest))
3537	(do		4284	(do
3538	(pr "<!-- ignoring " opt " for " spec "-->")		4285	(pr "<!-- ignoring " opt " for " spec "-->")
3539	(tag-options spec rest)))))))		4286	(tag-options spec rest)))))))
		-+	4287
			4288	(def precomputable-tagopt (val)
			4289	(and (literal val)
			4290	(no (and (is (type val) 'string) (find #\@ val)))))
3540		=	4291
3541	(def br ((o n 1))		4292	(def br ((o n 1))
3542	(repeat n (pr "<br>"))		4293	(repeat n (pr "<br>"))
3543	(prn))		4294	(prn))
3544			4295
3545	(def br2 () (prn "<br><br>"))		4296	(def br2 () (prn "<br><br>"))
3546			4297
3547	(mac center body `(tag center ,@body))		4298	(mac center body `(tag center ,@body))
3548	(mac underline body `(tag u ,@body))		4299	(mac underline body `(tag u ,@body))
3549	(mac tab body `(tag (table border 0) ,@body))		4300	(mac tab body `(tag (table border 0) ,@body))
3550	(mac tr body `(tag tr ,@body))		4301	(mac tr body `(tag tr ,@body))
3551			4302
3552	(let pratoms (fn (body)		4303	(let pratoms (fn (body)
3553	(if (or (no body)		4304	(if (or (no body)
3554	(all [and (acons _) (isnt (car _) 'quote)]		4305	(all [and (acons _) (isnt (car _) 'quote)]
3555	body))		4306	body))
3556	body		4307	body
3557	`((pr ,@body))))		4308	`((pr ,@body))))
3558			4309
3559	(mac td body `(tag td ,@(pratoms body)))		4310	(mac td body `(tag td ,@(pratoms body)))
3560	(mac trtd body `(tr (td ,@(pratoms body))))		4311	(mac trtd body `(tr (td ,@(pratoms body))))
3561	(mac tdright body `(tag (td align 'right) ,@(pratoms body)))	<>	4312	(mac tdr body `(tag (td align 'right) ,@(pratoms body)))
3562	(mac tdcolor (col . body) `(tag (td bgcolor ,col) ,@(pratoms body)))	=	4313	(mac tdcolor (col . body) `(tag (td bgcolor ,col) ,@(pratoms body)))
3563	)		4314	)
3564			4315
3565	(mac row args		4316	(mac row args
3566	`(tr ,@(map [list 'td _] args)))		4317	`(tr ,@(map [list 'td _] args)))
3567			4318
3568	(mac prrow args		4319	(mac prrow args
3569	(w/uniq g		4320	(w/uniq g
3570	`(tr ,@(map (fn (a)		4321	`(tr ,@(map (fn (a)
3571	`(let ,g ,a		4322	`(let ,g ,a
3572	(if (number ,g)		4323	(if (number ,g)
3573	(tdright (pr ,g))	<>	4324	(tdr (pr ,g))
3574	(td (pr ,g)))))	=	4325	(td (pr ,g)))))
3575	args))))		4326	args))))
3576			4327
3577	(mac prbold body `(tag b (pr ,@body)))		4328	(mac prbold body `(tag b (pr ,@body)))
3578			4329
		<>	4330	(def para args
			4331	(gentag p)
3579	(def para () (gentag p))		4332	(when args (apply pr args)))
3580		=	4333
3581	(def menu (name items (o sel nil))		4334	(def menu (name items (o sel nil))
3582	(tag (select name name)		4335	(tag (select name name)
3583	(each i items		4336	(each i items
3584	(tag (option selected (is i sel))		4337	(tag (option selected (is i sel))
3585	(pr i)))))		4338	(pr i)))))
3586			4339
3587	(mac whitepage body		4340	(mac whitepage body
3588	`(tag html		4341	`(tag html
3589	(tag (body bgcolor white alink linkblue) ,@body)))		4342	(tag (body bgcolor white alink linkblue) ,@body)))
3590			4343
3591	(def errpage args (whitepage (apply prn args)))		4344	(def errpage args (whitepage (apply prn args)))
3592			4345
3593	(= local-images* nil) ; set to t when developing offline	<>
3594
3595	(def img-url (file)
3596	(string (unless local-images* "http://ycombinator.com/images/") file))
3597
3598	(def blank-url ()		4346	(def blank-url () "s.gif")
3599	(if local-images* "s.gif" "http://ycombinator.com/images/s.gif"))
3600		=	4347
3601	; Could memoize these.		4348	; Could memoize these.
3602			4349
3603	; If h = 0, doesn't affect table column widths in some Netscapes.		4350	; If h = 0, doesn't affect table column widths in some Netscapes.
3604			4351
3605	(def hspace (n) (gentag img src (blank-url) height 1 width n))		4352	(def hspace (n) (gentag img src (blank-url) height 1 width n))
3606	(def vspace (n) (gentag img src (blank-url) height n width 0))		4353	(def vspace (n) (gentag img src (blank-url) height n width 0))
3607	(def vhspace (h w) (gentag img src (blank-url) height h width w))		4354	(def vhspace (h w) (gentag img src (blank-url) height h width w))
3608			4355
3609	(mac new-hspace (n)		4356	(mac new-hspace (n)
3610	(if (number n)		4357	(if (number n)
3611	`(pr ,(string "<span style=\"padding-left:" n "px\" />"))		4358	`(pr ,(string "<span style=\"padding-left:" n "px\" />"))
3612	`(pr "<span style=\"padding-left:" ,n "px\" />")))		4359	`(pr "<span style=\"padding-left:" ,n "px\" />")))
3613			4360
3614	;(def spacerow (h) (tr (td (vspace h))))		4361	;(def spacerow (h) (tr (td (vspace h))))
3615			4362
3616	(def spacerow (h) (pr "<tr style=\"height:" h "px\"></tr>"))		4363	(def spacerow (h) (pr "<tr style=\"height:" h "px\"></tr>"))
3617			4364
3618	; For use as nested table.		4365	; For use as nested table.
3619			4366
3620	(mac zerotable body		4367	(mac zerotable body
3621	`(tag (table border 0 cellpadding 0 cellspacing 0)		4368	`(tag (table border 0 cellpadding 0 cellspacing 0)
3622	,@body))		4369	,@body))
3623			4370
		<>	4371	; was `(tag (table border 0 cellpadding 0 cellspacing 7) ,@body)
			4372
3624	(mac spacetable body		4373	(mac sptab body
3625	`(tag (table border 0 cellpadding 0 cellspacing 7) ,@body))		4374	`(tag (table style "border-spacing: 7px 0px;") ,@body))
3626		=	4375
3627	(mac widtable (w . body)		4376	(mac widtable (w . body)
3628	`(tag (table width ,w) (tr (td ,@body))))		4377	`(tag (table width ,w) (tr (td ,@body))))
3629			4378
3630	(def cellpr (x) (pr (or x " ")))		4379	(def cellpr (x) (pr (or x " ")))
3631			4380
3632	(def but ((o text "submit") (o name nil))		4381	(def but ((o text "submit") (o name nil))
3633	(gentag input type 'submit name name value text))		4382	(gentag input type 'submit name name value text))
3634			4383
3635	(def submit ((o val "submit"))		4384	(def submit ((o val "submit"))
3636	(gentag input type 'submit value val))		4385	(gentag input type 'submit value val))
3637			4386
3638	(def buts (name . texts)		4387	(def buts (name . texts)
3639	(if (no texts)		4388	(if (no texts)
3640	(but)		4389	(but)
3641	(do (but (car texts) name)		4390	(do (but (car texts) name)
3642	(each text (cdr texts)		4391	(each text (cdr texts)
3643	(pr " ")		4392	(pr " ")
3644	(but text name)))))		4393	(but text name)))))
3645			4394
3646	(mac spanrow (n . body)		4395	(mac spanrow (n . body)
3647	`(tr (tag (td colspan ,n) ,@body)))		4396	`(tr (tag (td colspan ,n) ,@body)))
3648			4397
3649	(mac form (action . body)		4398	(mac form (action . body)
3650	`(tag (form method "post" action ,action) ,@body))		4399	`(tag (form method "post" action ,action) ,@body))
3651			4400
3652	(mac textarea (name rows cols . body)		4401	(mac textarea (name rows cols . body)
3653	`(tag (textarea name ,name rows ,rows cols ,cols) ,@body))		4402	`(tag (textarea name ,name rows ,rows cols ,cols) ,@body))
3654			4403
3655	(def input (name (o val "") (o size 10))		4404	(def input (name (o val "") (o size 10))
3656	(gentag input type 'text name name value val size size))		4405	(gentag input type 'text name name value val size size))
3657			4406
3658	(mac inputs args		4407	(mac inputs args
3659	`(tag (table border 0)		4408	`(tag (table border 0)
3660	,@(map (fn ((name label len text))		4409	,@(map (fn ((name label len text))
3661	(w/uniq (gl gt)		4410	(w/uniq (gl gt)
3662	`(let ,gl ,len		4411	`(let ,gl ,len
3663	(tr (td (pr ',label ":"))		4412	(tr (td (pr ',label ":"))
3664	(if (isa ,gl 'cons)		4413	(if (isa ,gl 'cons)
3665	(td (textarea ',name (car ,gl) (cadr ,gl)		4414	(td (textarea ',name (car ,gl) (cadr ,gl)
3666	(let ,gt ,text (if ,gt (pr ,gt)))))		4415	(let ,gt ,text (if ,gt (pr ,gt)))))
3667	(td (gentag input type ',(if (is label 'password)		4416	(td (gentag input type ',(if (is label 'password)
3668	'password		4417	'password
3669	'text)		4418	'text)
3670	name ',name		4419	name ',name
3671	size ,len		4420	size ,len
3672	value ,text)))))))		4421	value ,text)))))))
3673	(tuples args 4))))		4422	(tuples args 4))))
3674			4423
		-+	4424	(def single-input (label name chars btext (o pwd))
			4425	(pr label)
			4426	(gentag input type (if pwd 'password 'text) name name size chars)
			4427	(sp)
			4428	(submit btext))
			4429
			4430	(mac cdata body
			4431	`(do (pr "<![CDATA[")
			4432	,@body
			4433	(pr "]]>")))
			4434
3675	(def eschtml (str)	=	4435	(def eschtml (str)
3676	(tostring		4436	(tostring
3677	(each c str		4437	(each c str
3678	(pr (case c #\< "<"		4438	(pr (case c #\< "<"
3679	#\> ">"		4439	#\> ">"
3680	#\" """		4440	#\" """
3681	#\' "'"		4441	#\' "'"
3682	#\& "&"		4442	#\& "&"
3683	c)))))		4443	c)))))
3684			4444
3685	(def esc<>& (str)	<>	4445	(def esc-tags (str)
3686	(tostring	=	4446	(tostring
3687	(each c str		4447	(each c str
3688	(pr (case c #\< "<"		4448	(pr (case c #\< "<"
3689	#\> ">"		4449	#\> ">"
3690	#\& "&"		4450	#\& "&"
3691	c)))))		4451	c)))))
3692			4452
3693	(def nbsp () (pr " "))		4453	(def nbsp () (pr " "))
3694			4454
3695	(def link (text (o dest text) (o color))		4455	(def link (text (o dest text) (o color))
3696	(tag (a href dest)		4456	(tag (a href dest)
3697	(tag-if color (font color color)		4457	(tag-if color (font color color)
3698	(pr text))))		4458	(pr text))))
3699			4459
3700	(def underlink (text (o dest text))		4460	(def underlink (text (o dest text))
3701	(tag (a href dest) (tag u (pr text))))		4461	(tag (a href dest) (tag u (pr text))))
3702			4462
3703	(def striptags (s)		4463	(def striptags (s)
3704	(let intag nil		4464	(let intag nil
3705	(tostring		4465	(tostring
3706	(each c s		4466	(each c s
3707	(if (is c #\<) (t! intag)	<>	4467	(if (is c #\<) (set intag)
3708	(is c #\>) (nil! intag)		4468	(is c #\>) (wipe intag)
3709	(no intag) (pr c))))))	=	4469	(no intag) (pr c))))))
3710			4470
		-+	4471	(def clean-url (u)
			4472	(rem [in _ #\" #\' #\< #\>] u))
			4473
3711	(def shortlink (url)	=	4474	(def shortlink (url)
3712	(unless (or (no url) (< (len url) 7))		4475	(unless (or (no url) (< (len url) 7))
3713	(link (subseq url 7) url)))	<>	4476	(link (cut url 7) url)))
3714		=	4477
3715	; this should be one regexp		4478	; this should be one regexp
3716			4479
3717	(def parafy (str)		4480	(def parafy (str)
3718	(let ink nil		4481	(let ink nil
3719	(tostring		4482	(tostring
3720	(each c str		4483	(each c str
3721	(pr c)		4484	(pr c)
3722	(unless (whitec c) (t! ink))	<>	4485	(unless (whitec c) (set ink))
3723	(when (is c #\newline)	=	4486	(when (is c #\newline)
3724	(unless ink (pr "<p>"))		4487	(unless ink (pr "<p>"))
3725	(nil! ink))))))	<>	4488	(wipe ink))))))
3726		=	4489
3727	(mac spanclass (name . body)		4490	(mac spanclass (name . body)
3728	`(tag (span class ',name) ,@body))		4491	`(tag (span class ',name) ,@body))
3729			4492
3730	(def pagemessage (text)		4493	(def pagemessage (text)
3731	(when text (prn text) (br2)))		4494	(when text (prn text) (br2)))
		-+	4495
			4496	; Could be stricter. Memoized because looking for chars in Unicode
			4497	; strings is terribly inefficient in Mzscheme.
			4498
			4499	(defmemo valid-url (url)
			4500	(and (len> url 10)
			4501	(or (begins url "http://")
			4502	(begins url "https://"))
			4503	(~find [in _ #\< #\> #\" #\'] url)))
			4504
			4505	(mac fontcolor (c . body)
			4506	(w/uniq g
			4507	`(let ,g ,c
			4508	(if ,g
			4509	(tag (font color ,g) ,@body)
			4510	(do ,@body)))))
3732		=	4511
3733	./libs.arc		4512	./libs.arc
3734	(map load '("strings.arc"		4513	(map load '("strings.arc"
3735	"pprint.arc"		4514	"pprint.arc"
3736	"code.arc"		4515	"code.arc"
3737	"html.arc"		4516	"html.arc"
3738	"srv.arc"		4517	"srv.arc"
3739	"app.arc"		4518	"app.arc"
3740	"prompt.arc"))		4519	"prompt.arc"))
3741			4520
3742	./pprint.arc		4521	./pprint.arc
3743	; Pretty-Printing. Spun off 4 Aug 06.		4522	; Pretty-Printing. Spun off 4 Aug 06.
3744			4523
3745	; todo: indentation of long ifs; quasiquote, unquote, unquote-splicing		4524	; todo: indentation of long ifs; quasiquote, unquote, unquote-splicing
3746			4525
3747	(= bodops* (fill-table (table)		4526	(= bodops* (fill-table (table)
3748	'(let 2 with 1 while 1 def 2 fn 1 rfn 2 afn 1		4527	'(let 2 with 1 while 1 def 2 fn 1 rfn 2 afn 1
3749	when 1 unless 1 after 1 whilet 2 for 3 each 2 whenlet 2 awhen 1		4528	when 1 unless 1 after 1 whilet 2 for 3 each 2 whenlet 2 awhen 1
3750	whitepage 0 tag 1 form 1 aform 1 aformh 1 w/link 1 textarea 3		4529	whitepage 0 tag 1 form 1 aform 1 aformh 1 w/link 1 textarea 3
3751	)))		4530	)))
3752			4531
3753	(= oneline* 35) ; print exprs less than this long on one line		4532	(= oneline* 35) ; print exprs less than this long on one line
3754			4533
3755	; If returns nil, can assume it didn't have to break expr.		4534	; If returns nil, can assume it didn't have to break expr.
3756			4535
3757	(def ppr (expr (o col 0) (o noindent nil))		4536	(def ppr (expr (o col 0) (o noindent nil))
3758	(if (or (atom expr) (dotted expr))		4537	(if (or (atom expr) (dotted expr))
3759	(do (unless noindent (sp col))		4538	(do (unless noindent (sp col))
3760	(write expr)		4539	(write expr)
3761	nil)		4540	nil)
3762	(is (car expr) 'quote)		4541	(is (car expr) 'quote)
3763	(do (unless noindent (sp col))		4542	(do (unless noindent (sp col))
3764	(pr "'")		4543	(pr "'")
3765	(ppr (cadr expr) (+ col 1) t))		4544	(ppr (cadr expr) (+ col 1) t))
3766	(bodops* (car expr))		4545	(bodops* (car expr))
3767	(do (unless noindent (sp col))		4546	(do (unless noindent (sp col))
3768	(let whole (tostring (write expr))		4547	(let whole (tostring (write expr))
3769	(if (< (len whole) oneline*)		4548	(if (< (len whole) oneline*)
3770	(do (pr whole) nil)		4549	(do (pr whole) nil)
3771	(ppr-progn expr col noindent))))		4550	(ppr-progn expr col noindent))))
3772	(do (unless noindent (sp col))		4551	(do (unless noindent (sp col))
3773	(let whole (tostring (write expr))		4552	(let whole (tostring (write expr))
3774	(if (< (len whole) oneline*)		4553	(if (< (len whole) oneline*)
3775	(do (pr whole) nil)		4554	(do (pr whole) nil)
3776	(ppr-call expr col noindent))))))		4555	(ppr-call expr col noindent))))))
3777			4556
3778	(def ppr-progn (expr col noindent)		4557	(def ppr-progn (expr col noindent)
3779	(lpar)		4558	(lpar)
3780	(let n (bodops* (car expr))		4559	(let n (bodops* (car expr))
3781	(let str (tostring (write-spaced (firstn n expr)))		4560	(let str (tostring (write-spaced (firstn n expr)))
3782	(unless (is n 0) (pr str) (sp))		4561	(unless (is n 0) (pr str) (sp))
3783	(ppr (expr n) (+ col (len str) 2) t))		4562	(ppr (expr n) (+ col (len str) 2) t))
3784	(map (fn (e) (prn) (ppr e (+ col 2)))		4563	(map (fn (e) (prn) (ppr e (+ col 2)))
3785	(nthcdr (+ n 1) expr)))		4564	(nthcdr (+ n 1) expr)))
3786	(rpar)		4565	(rpar)
3787	t)		4566	t)
3788			4567
3789	(def ppr-call (expr col noindent)		4568	(def ppr-call (expr col noindent)
3790	(lpar)		4569	(lpar)
3791	(let carstr (tostring (write (car expr)))		4570	(let carstr (tostring (write (car expr)))
3792	(pr carstr)		4571	(pr carstr)
3793	(if (cdr expr)		4572	(if (cdr expr)
3794	(do (sp)		4573	(do (sp)
3795	(let broke (ppr (cadr expr) (+ col (len carstr) 2) t)		4574	(let broke (ppr (cadr expr) (+ col (len carstr) 2) t)
3796	(pprest (cddr expr)		4575	(pprest (cddr expr)
3797	(+ col (len carstr) 2)		4576	(+ col (len carstr) 2)
3798	(no broke)))		4577	(no broke)))
3799	t)		4578	t)
3800	(do (rpar) t))))		4579	(do (rpar) t))))
3801			4580
3802	(def pprest (exprs col (o oneline t))		4581	(def pprest (exprs col (o oneline t))
3803	(if (and oneline		4582	(if (and oneline
3804	(all (fn (e)		4583	(all (fn (e)
3805	(or (atom e) (and (is (car e) 'quote) (atom (cadr e)))))		4584	(or (atom e) (and (is (car e) 'quote) (atom (cadr e)))))
3806	exprs))		4585	exprs))
3807	(do (map (fn (e) (pr " ") (write e))		4586	(do (map (fn (e) (pr " ") (write e))
3808	exprs)		4587	exprs)
3809	(rpar))		4588	(rpar))
3810	(do (when exprs		4589	(do (when exprs
3811	(each e exprs (prn) (ppr e col)))		4590	(each e exprs (prn) (ppr e col)))
3812	(rpar))))		4591	(rpar))))
3813			4592
3814	(def write-spaced (xs)		4593	(def write-spaced (xs)
3815	(when xs		4594	(when xs
3816	(write (car xs))		4595	(write (car xs))
3817	(each x (cdr xs) (pr " ") (write x))))		4596	(each x (cdr xs) (pr " ") (write x))))
3818			4597
3819	(def sp ((o n 1)) (repeat n (pr " ")))		4598	(def sp ((o n 1)) (repeat n (pr " ")))
3820	(def lpar () (pr "("))		4599	(def lpar () (pr "("))
3821	(def rpar () (pr ")"))		4600	(def rpar () (pr ")"))
3822			4601
3823			4602
3824	./prompt.arc		4603	./prompt.arc
3825	; Prompt: Web-based programming application. 4 Aug 06.		4604	; Prompt: Web-based programming application. 4 Aug 06.
3826			4605
3827	(= appdir* "arc/apps/")		4606	(= appdir* "arc/apps/")
3828			4607
3829	(defop prompt req		4608	(defop prompt req
3830	(let user (get-user req)		4609	(let user (get-user req)
3831	(if (admin user)		4610	(if (admin user)
3832	(prompt-page user)		4611	(prompt-page user)
3833	(pr "Sorry."))))		4612	(pr "Sorry."))))
3834			4613
3835	(def prompt-page (user . msg)		4614	(def prompt-page (user . msg)
3836	(ensure-dir appdir*)		4615	(ensure-dir appdir*)
3837	(ensure-dir (string appdir* user))		4616	(ensure-dir (string appdir* user))
3838	(whitepage		4617	(whitepage
3839	(prbold "Prompt")		4618	(prbold "Prompt")
3840	(hspace 20)		4619	(hspace 20)
3841	(pr user " \| ")		4620	(pr user " \| ")
3842	(link "logout")		4621	(link "logout")
3843	(when msg (hspace 10) (apply pr msg))		4622	(when msg (hspace 10) (apply pr msg))
3844	(br2)		4623	(br2)
3845	(tag (table border 0 cellspacing 10)		4624	(tag (table border 0 cellspacing 10)
3846	(each app (dir (+ appdir* user))		4625	(each app (dir (+ appdir* user))
3847	(tr (td app)		4626	(tr (td app)
3848	(td (userlink user 'edit (edit-app user app)))	<>	4627	(td (ulink user 'edit (edit-app user app)))
3849	(td (userlink user 'run (run-app user app)))		4628	(td (ulink user 'run (run-app user app)))
3850	(td (hspace 40)	=	4629	(td (hspace 40)
3851	(userlink user 'delete (rem-app user app))))))	<>	4630	(ulink user 'delete (rem-app user app))))))
3852	(br2)	=	4631	(br2)
3853	(aform (fn (req)		4632	(aform (fn (req)
3854	(when-usermatch user req	<>	4633	(when-umatch user req
3855	(aif (goodname (arg req "app"))	=	4634	(aif (goodname (arg req "app"))
3856	(edit-app user it)		4635	(edit-app user it)
3857	(prompt-page user "Bad name."))))		4636	(prompt-page user "Bad name."))))
3858	(tab (row "name:" (input "app") (submit "create app"))))))		4637	(tab (row "name:" (input "app") (submit "create app"))))))
3859			4638
3860	(def app-path (user app)		4639	(def app-path (user app)
3861	(and user app (+ appdir* user "/" app)))		4640	(and user app (+ appdir* user "/" app)))
3862			4641
3863	(def read-app (user app)		4642	(def read-app (user app)
3864	(aand (app-path user app)		4643	(aand (app-path user app)
3865	(file-exists it)		4644	(file-exists it)
3866	(w/infile i it (readall i))))	<>	4645	(readfile it)))
3867		=	4646
3868	(def write-app (user app exprs)		4647	(def write-app (user app exprs)
3869	(awhen (app-path user app)		4648	(awhen (app-path user app)
3870	(w/outfile o it		4649	(w/outfile o it
3871	(each e exprs (write e o)))))		4650	(each e exprs (write e o)))))
3872			4651
3873	(def rem-app (user app)		4652	(def rem-app (user app)
3874	(let file (app-path user app)		4653	(let file (app-path user app)
3875	(if (file-exists file)		4654	(if (file-exists file)
3876	(do (rmfile (app-path user app))		4655	(do (rmfile (app-path user app))
3877	(prompt-page user "Program " app " deleted."))		4656	(prompt-page user "Program " app " deleted."))
3878	(prompt-page user "No such app."))))		4657	(prompt-page user "No such app."))))
3879			4658
3880	(def edit-app (user app)		4659	(def edit-app (user app)
3881	(whitepage		4660	(whitepage
3882	(pr "user: " user " app: " app)		4661	(pr "user: " user " app: " app)
3883	(br2)		4662	(br2)
3884	(aform (fn (req)		4663	(aform (fn (req)
3885	(let u2 (get-user req)		4664	(let u2 (get-user req)
3886	(if (is u2 user)		4665	(if (is u2 user)
3887	(do (when (is (arg req "cmd") "save")		4666	(do (when (is (arg req "cmd") "save")
3888	(write-app user app (readall (arg req "exprs"))))		4667	(write-app user app (readall (arg req "exprs"))))
3889	(prompt-page user))		4668	(prompt-page user))
3890	(login-page 'both nil		4669	(login-page 'both nil
3891	(fn (u ip) (prompt-page u))))))		4670	(fn (u ip) (prompt-page u))))))
3892	(textarea "exprs" 10 82		4671	(textarea "exprs" 10 82
3893	(pprcode (read-app user app)))		4672	(pprcode (read-app user app)))
3894	(br2)		4673	(br2)
3895	(buts 'cmd "save" "cancel"))))		4674	(buts 'cmd "save" "cancel"))))
3896			4675
3897	(def pprcode (exprs)		4676	(def pprcode (exprs)
3898	(each e exprs		4677	(each e exprs
3899	(ppr e)		4678	(ppr e)
3900	(pr "\n\n")))		4679	(pr "\n\n")))
3901			4680
3902	(def view-app (user app)		4681	(def view-app (user app)
3903	(whitepage		4682	(whitepage
3904	(pr "user: " user " app: " app)		4683	(pr "user: " user " app: " app)
3905	(br2)		4684	(br2)
3906	(tag xmp (pprcode (read-app user app)))))		4685	(tag xmp (pprcode (read-app user app)))))
3907			4686
3908	(def run-app (user app)		4687	(def run-app (user app)
3909	(let exprs (read-app user app)		4688	(let exprs (read-app user app)
3910	(if exprs		4689	(if exprs
3911	(on-err (fn (c) (pr "Error: " (details c)))		4690	(on-err (fn (c) (pr "Error: " (details c)))
3912	(fn () (map eval exprs)))		4691	(fn () (map eval exprs)))
3913	(prompt-page user "Error: No application " app " for user " user))))		4692	(prompt-page user "Error: No application " app " for user " user))))
3914			4693
3915	(nil! repl-history*)	<>	4694	(wipe repl-history*)
3916		=	4695
3917	(defop repl req		4696	(defop repl req
3918	(if (admin (get-user req))		4697	(if (admin (get-user req))
3919	(replpage req)		4698	(replpage req)
3920	(pr "Sorry.")))		4699	(pr "Sorry.")))
3921			4700
3922	(def replpage (req)		4701	(def replpage (req)
3923	(whitepage		4702	(whitepage
3924	(repl (readall (or (arg req "expr") "")) "repl")))		4703	(repl (readall (or (arg req "expr") "")) "repl")))
3925			4704
3926	(def repl (exprs url)		4705	(def repl (exprs url)
3927	(each expr exprs		4706	(each expr exprs
3928	(on-err (fn (c) (push (list expr c t) repl-history*))		4707	(on-err (fn (c) (push (list expr c t) repl-history*))
3929	(fn ()		4708	(fn ()
3930	(= that (eval expr) thatexpr expr)		4709	(= that (eval expr) thatexpr expr)
3931	(push (list expr that) repl-history*))))		4710	(push (list expr that) repl-history*))))
3932	(form url		4711	(form url
3933	(textarea "expr" 8 60)		4712	(textarea "expr" 8 60)
3934	(sp)		4713	(sp)
3935	(submit))		4714	(submit))
3936	(tag xmp		4715	(tag xmp
3937	(each (expr val err) (firstn 20 repl-history*)		4716	(each (expr val err) (firstn 20 repl-history*)
3938	(pr "> ")		4717	(pr "> ")
3939	(ppr expr)		4718	(ppr expr)
3940	(prn)		4719	(prn)
3941	(prn (if err "Error: " "")		4720	(prn (if err "Error: " "")
3942	(ellipsize (tostring (write val)) 800)))))		4721	(ellipsize (tostring (write val)) 800)))))
3943			4722
3944			4723
3945	./srv.arc		4724	./srv.arc
3946	; (server) then http://tintin.archub.org:8080/foo	<>
3947			4725	; HTTP Server.
3948	; could make form fields that know their value type because of		4726
3949	; gensymed names, and so the receiving fn gets args that are not		4727	; To improve performance with static files, set static-max-age*.
3950	; strings but parsed values.		4728
3951			4729	(= arcdir* "arc/" logdir* "arc/logs/" staticdir* "static/")
3952	; write w/socket
3953		=	4730
3954	; set breaksrv* to t to be able to ^c the server	<>
3955			4731	(= quitsrv* nil breaksrv* nil)
3956	(= arcdir* "arc/" logdir* "arc/logs/" quitsrv* nil breaksrv* nil)
3957		=	4732
3958	(def serve ((o port 8080))		4733	(def serve ((o port 8080))
3959	(nil! quitsrv*)	<>	4734	(wipe quitsrv*)
3960	(ensure-install)		4735	(ensure-srvdirs)
			4736	(map [apply new-bgthread _] pending-bgthreads*)
3961	(let s (open-socket port)		4737	(w/socket s port
			4738	(setuid 2) ; XXX switch from root to pg
3962	(prn "ready to serve port " port) ; (flushout)		4739	(prn "ready to serve port " port)
			4740	(flushout)
3963	(= currsock* s)	=	4741	(= currsock* s)
3964	(after (while (no quitsrv*)	<>	4742	(until quitsrv*
3965	(if breaksrv*
3966	(handle-request s)
3967	(errsafe (handle-request s))))		4743	(handle-request s breaksrv*)))
3968	(close s)
3969	(prn "quit server"))))		4744	(prn "quit server"))
3970		=	4745
3971	(def serve1 ((o port 8080))		4746	(def serve1 ((o port 8080))
3972	(let s (open-socket port)	<>	4747	(w/socket s port (handle-request s t)))
3973	(after (handle-request s) (close s))))		4748
			4749	(def ensure-srvdirs ()
			4750	(map ensure-dir (list arcdir* logdir* staticdir*)))
3974		=	4751
3975	(= srv-noisy* nil)		4752	(= srv-noisy* nil)
3976			4753
3977	; http requests currently capped at 2 meg by socket-accept		4754	; http requests currently capped at 2 meg by socket-accept
3978			4755
3979	; should threads process requests one at a time? no, then		4756	; should threads process requests one at a time? no, then
3980	; a browser that's slow consuming the data could hang the		4757	; a browser that's slow consuming the data could hang the
3981	; whole server.		4758	; whole server.
3982			4759
3983	; wait for a connection from a browser and start a thread		4760	; wait for a connection from a browser and start a thread
3984	; to handle it. also arrange to kill that thread if it		4761	; to handle it. also arrange to kill that thread if it
3985	; has not completed in threadlife* seconds.		4762	; has not completed in threadlife* seconds.
3986			4763
3987	(= srvthreads* nil threadlimit* 50 threadlife* 30)	<>	4764	(= threadlife* 30 requests* 0 requests/ip* (table)
3988			4765	throttle-ips* (table) ignore-ips* (table) spurned* (table))
3989	; Could auto-throttle ips, e.g. if one has more than x% of recent requests.		4766
3990			4767	(def handle-request (s breaksrv)
3991	(= requests* 0 requests/ip* (table) throttle-ips* (table) throttle-time* 60)		4768	(if breaksrv
3992			4769	(handle-request-1 s)
3993	(def handle-request (s (o life threadlife*))		4770	(errsafe (handle-request-1 s))))
3994	(if (< (len (= srvthreads* (rem dead srvthreads*)))		4771
3995	threadlimit*)		4772	(def handle-request-1 (s)
3996	(with ((i o ip) (socket-accept s))		4773	(let (i o ip) (socket-accept s)
			4774	(if (and (or (ignore-ips* ip) (abusive-ip ip))
			4775	(++ (spurned* ip 0)))
			4776	(force-close i o)
3997	(++ requests*)		4777	(do (++ requests*)
3998	(= (requests/ip* ip) (+ 1 (or (requests/ip* ip) 0)))		4778	(++ (requests/ip* ip 0))
			4779	(with (th1 nil th2 nil)
3999	(let th (thread (fn ()		4780	(= th1 (thread
4000	(if (throttle-ips* ip) (sleep (rand throttle-time*)))		4781	(after (handle-request-thread i o ip)
			4782	(close i o)
4001	(handle-request-thread i o ip)))		4783	(kill-thread th2))))
4002	(push th srvthreads*)
4003	(thread (fn ()		4784	(= th2 (thread
4004	(sleep life)		4785	(sleep threadlife*)
			4786	(unless (dead th1)
4005	(unless (dead th) (prn "srv thread took too long"))		4787	(prn "srv thread took too long for " ip))
4006	(break-thread th)		4788	(break-thread th1)
			4789	(force-close i o))))))))
4007	(close o)		4790
			4791	; Returns true if ip has made req-limit* requests in less than
			4792	; req-window* seconds. If an ip is throttled, only 1 request is
			4793	; allowed per req-window* seconds. If an ip makes req-limit*
			4794	; requests in less than dos-window* seconds, it is a treated as a DoS
			4795	; attack and put in ignore-ips* (for this server invocation).
4008	(close i)))))		4796
			4797	; To adjust this while running, adjust the req-window* time, not
			4798	; req-limit*, because algorithm doesn't enforce decreases in the latter.
4009	(sleep .2)))		4799
			4800	(= req-times* (table) req-limit* 30 req-window* 10 dos-window* 2)
4010		=	4801
		-+	4802	(def abusive-ip (ip)
			4803	(and (only.> (requests/ip* ip) 250)
			4804	(let now (seconds)
			4805	(do1 (if (req-times* ip)
			4806	(and (>= (qlen (req-times* ip))
			4807	(if (throttle-ips* ip) 1 req-limit*))
			4808	(let dt (- now (deq (req-times* ip)))
			4809	(if (< dt dos-window) (set (ignore-ips ip)))
			4810	(< dt req-window*)))
			4811	(do (= (req-times* ip) (queue))
			4812	nil))
			4813	(enq now (req-times* ip))))))
			4814
4011	(def handle-request-thread (i o ip)	=	4815	(def handle-request-thread (i o ip)
4012	(with (nls 0 lines nil line nil responded nil)	<>	4816	(with (nls 0 lines nil line nil responded nil t0 (msec))
4013	(after	=	4817	(after
4014	(whilet c (and (no responded) (readc i))	<>	4818	(whilet c (unless responded (readc i))
4015	(if srv-noisy* (pr c))	=	4819	(if srv-noisy* (pr c))
4016	(if (is c #\newline)		4820	(if (is c #\newline)
4017	(if (is (++ nls) 2)		4821	(if (is (++ nls) 2)
4018	(do (let (type op args n cooks) (parseheader (rev lines))	<>	4822	(let (type op args n cooks) (parseheader (rev lines))
4019	(srvlog 'srv ip type op cooks)		4823	(let t1 (msec)
4020	(case type		4824	(case type
4021	get (respond o op args cooks ip)		4825	get (respond o op args cooks ip)
4022	post (handle-post i o op n cooks ip)		4826	post (handle-post i o op args n cooks ip)
4023	(respond-err o "Unknown request: " (car lines))))		4827	(respond-err o "Unknown request: " (car lines)))
			4828	(log-request type op args cooks ip t0 t1)
4024	(= responded t))		4829	(set responded)))
4025	(do (push (coerce (rev line) 'string) lines)		4830	(do (push (string (rev line)) lines)
4026	(= line nil)))		4831	(wipe line)))
4027	(unless (is c #\return)	=	4832	(unless (is c #\return)
4028	(push c line)		4833	(push c line)
4029	(= nls 0))))		4834	(= nls 0))))
4030	(close o)	<>
4031	(close i)))		4835	(close i o)))
4032	(harvest-fnids))	=	4836	(harvest-fnids))
4033			4837
		-+	4838	(def log-request (type op args cooks ip t0 t1)
			4839	(with (parsetime (- t1 t0) respondtime (- (msec) t1))
			4840	(srvlog 'srv ip
			4841	parsetime
			4842	respondtime
			4843	(if (> (+ parsetime respondtime) 1000) "***" "")
			4844	type
			4845	op
			4846	(let arg1 (car args)
			4847	(if (caris arg1 "fnid") "" arg1))
			4848	cooks)))
			4849
4034	; Could ignore return chars (which come from textarea fields) here by	=	4850	; Could ignore return chars (which come from textarea fields) here by
4035	; (unless (is c #\return) (push c line))		4851	; (unless (is c #\return) (push c line))
4036			4852
4037	(def handle-post (i o op n cooks ip)	<>	4853	(def handle-post (i o op args n cooks ip)
4038	(if srv-noisy* (pr "Post Contents: "))	=	4854	(if srv-noisy* (pr "Post Contents: "))
4039	(if (no n)		4855	(if (no n)
4040	(respond-err o "Post request without Content-Length.")		4856	(respond-err o "Post request without Content-Length.")
4041	(let line nil		4857	(let line nil
4042	(whilet c (and (> n 0) (readc i))		4858	(whilet c (and (> n 0) (readc i))
4043	(if srv-noisy* (pr c))		4859	(if srv-noisy* (pr c))
4044	(-- n)		4860	(-- n)
4045	(push c line))		4861	(push c line))
4046	(if srv-noisy* (pr "\n\n"))		4862	(if srv-noisy* (pr "\n\n"))
4047	(respond o op (parseargs (coerce (rev line) 'string)) cooks ip))))	<>	4863	(respond o op (+ (parseargs (string (rev line))) args) cooks ip))))
4048		=	4864
4049	(= header* "HTTP/1.0 200 OK	<>	4865	(= header* "HTTP/1.1 200 OK
4050	Content-Type: text/html		4866	Content-Type: text/html; charset=utf-8
4051	Connection: close")	=	4867	Connection: close")
4052			4868
		<>	4869	(= type-header* (table))
			4870
			4871	(def gen-type-header (ctype)
4053	(= gif-header* "HTTP/1.0 200 OK		4872	(+ "HTTP/1.0 200 OK
4054	Content-Type: image/gif		4873	Content-Type: "
			4874	ctype
			4875	"
4055	Connection: close")		4876	Connection: close"))
4056		=	4877
		-+	4878	(map (fn ((k v)) (= (type-header* k) (gen-type-header v)))
			4879	'((gif "image/gif")
			4880	(jpg "image/jpeg")
			4881	(png "image/png")
			4882	(text/html "text/html; charset=utf-8")))
			4883
4057	(= rdheader* "HTTP/1.0 302 Moved")	=	4884	(= rdheader* "HTTP/1.0 302 Moved")
4058			4885
4059	(= srvops* (table) redirectors* (table) optimes* (table))	<>	4886	(= srvops* (table) redirector* (table) optimes* (table) opcounts* (table))
4060		=	4887
4061	(def save-optime (name elapsed)		4888	(def save-optime (name elapsed)
		-+	4889	; this is the place to put a/b testing
			4890	; toggle a flag and push elapsed into one of two lists
			4891	(++ (opcounts* name 0))
4062	(unless (optimes* name) (= (optimes* name) (queue)))	=	4892	(unless (optimes* name) (= (optimes* name) (queue)))
4063	(enq-limit elapsed (optimes* name) 1000))		4893	(enq-limit elapsed (optimes* name) 1000))
4064			4894
4065	; For ops that want to add their own headers. They must thus remember		4895	; For ops that want to add their own headers. They must thus remember
4066	; to prn a blank line before anything meant to be part of the page.		4896	; to prn a blank line before anything meant to be part of the page.
4067			4897
4068	(mac defop-raw (name parms . body)		4898	(mac defop-raw (name parms . body)
4069	(w/uniq t1		4899	(w/uniq t1
4070	`(= (srvops* ',name)		4900	`(= (srvops* ',name)
4071	(fn ,parms		4901	(fn ,parms
4072	(let ,t1 (msec)		4902	(let ,t1 (msec)
4073	(do1 (do ,@body)		4903	(do1 (do ,@body)
4074	(save-optime ',name (- (msec) ,t1))))))))		4904	(save-optime ',name (- (msec) ,t1))))))))
4075			4905
4076	(mac defopr-raw (name parms . body)		4906	(mac defopr-raw (name parms . body)
4077	`(= (redirectors* ',name) t	<>	4907	`(= (redirector* ',name) t
4078	(srvops* ',name) (fn ,parms ,@body)))		4908	(srvops* ',name) (fn ,parms ,@body)))
4079		=	4909
4080	(mac defop (name parm . body)		4910	(mac defop (name parm . body)
4081	(w/uniq gs		4911	(w/uniq gs
		<>	4912	`(do (wipe (redirector* ',name))
4082	`(defop-raw ,name (,gs ,parm)		4913	(defop-raw ,name (,gs ,parm)
4083	(w/stdout ,gs (prn) ,@body))))		4914	(w/stdout ,gs (prn) ,@body)))))
4084		=	4915
4085	; Defines op as a redirector. Its retval is new location.		4916	; Defines op as a redirector. Its retval is new location.
4086			4917
4087	(mac defopr (name parm . body)		4918	(mac defopr (name parm . body)
4088	(w/uniq gs		4919	(w/uniq gs
4089	`(do (t! (redirectors* ',name))	<>	4920	`(do (set (redirector* ',name))
4090	(defop-raw ,name (,gs ,parm)	=	4921	(defop-raw ,name (,gs ,parm)
4091	,@body))))		4922	,@body))))
4092			4923
4093	;(mac testop (name . args) `((srvops* ',name) ,@args))		4924	;(mac testop (name . args) `((srvops* ',name) ,@args))
4094			4925
4095	(deftem request		4926	(deftem request
4096	args nil		4927	args nil
4097	cooks nil		4928	cooks nil
4098	ip nil)		4929	ip nil)
4099			4930
4100	(= unknown-msg* "Unknown operator.")	<>	4931	(= unknown-msg* "Unknown." max-age* (table) static-max-age* nil)
4101		=	4932
4102	(def respond (str op args cooks ip)		4933	(def respond (str op args cooks ip)
4103	(w/stdout str		4934	(w/stdout str
4104	(if (gifname op)	<>
4105	(do (prn gif-header*)
4106	(prn)
4107	(w/infile i (coerce op 'string)
4108	(whilet b (readb i)
4109	(writeb b str))))
4110	(aif (srvops* op)		4935	(iflet f (srvops* op)
4111	(let req (inst 'request 'args args 'cooks cooks 'ip ip)		4936	(let req (inst 'request 'args args 'cooks cooks 'ip ip)
4112	(if (redirectors* op)		4937	(if (redirector* op)
4113	(do (prn rdheader*)		4938	(do (prn rdheader*)
4114	(let loc (it str req) ; may write to str, e.g. cookies
4115	(prn "Location: " loc))		4939	(prn "Location: " (f str req))
4116	(prn))		4940	(prn))
4117	(do (prn header*)		4941	(do (prn header*)
			4942	(awhen (max-age* op)
			4943	(prn "Cache-Control: max-age=" it))
4118	(it str req))))		4944	(f str req))))
			4945	(let filetype (static-filetype op)
			4946	(aif (and filetype (file-exists (string staticdir* op)))
			4947	(do (prn (type-header* filetype))
			4948	(awhen static-max-age*
			4949	(prn "Cache-Control: max-age=" it))
			4950	(prn)
			4951	(w/infile i it
			4952	(whilet b (readb i)
			4953	(writeb b str))))
4119	(respond-err str unknown-msg*)))))		4954	(respond-err str unknown-msg*))))))
4120		=	4955
4121	(def gifname (sym)	<>	4956	(def static-filetype (sym)
4122	(let str (coerce sym 'string)		4957	(let fname (coerce sym 'string)
4123	(and (endmatch ".gif" str) (~find #\/ str))))		4958	(and (~find #\/ fname)
			4959	(case (downcase (last (check (tokens fname #\.) ~single)))
			4960	"gif" 'gif
			4961	"jpg" 'jpg
			4962	"jpeg" 'jpg
			4963	"png" 'png
			4964	"css" 'text/html
			4965	"txt" 'text/html
			4966	"htm" 'text/html
			4967	"html" 'text/html
			4968	"arc" 'text/html
			4969	))))
4124		=	4970
4125	(def respond-err (str msg . args)		4971	(def respond-err (str msg . args)
4126	(w/stdout str		4972	(w/stdout str
4127	(prn header*)		4973	(prn header*)
4128	(prn)		4974	(prn)
4129	(apply pr msg args)))		4975	(apply pr msg args)))
4130			4976
4131	(def parseheader (lines)		4977	(def parseheader (lines)
4132	(let (type op args) (parseurl (car lines))		4978	(let (type op args) (parseurl (car lines))
4133	(list type		4979	(list type
4134	op		4980	op
4135	args		4981	args
4136	(and (is type 'post)		4982	(and (is type 'post)
4137	(some (fn (s)		4983	(some (fn (s)
4138	(and (begins s "Content-Length:")		4984	(and (begins s "Content-Length:")
4139	(coerce (cadr (tokens s)) 'int)))	<>	4985	(errsafe:coerce (cadr (tokens s)) 'int)))
4140	(cdr lines)))	=	4986	(cdr lines)))
4141	(some (fn (s)		4987	(some (fn (s)
4142	(and (begins s "Cookie:")		4988	(and (begins s "Cookie:")
4143	(parsecookies s)))		4989	(parsecookies s)))
4144	(cdr lines)))))		4990	(cdr lines)))))
4145			4991
4146	; (parseurl "GET /p1?foo=bar&ug etc") -> (get p1 (("foo" "bar") ("ug")))		4992	; (parseurl "GET /p1?foo=bar&ug etc") -> (get p1 (("foo" "bar") ("ug")))
4147			4993
4148	(def parseurl (s)		4994	(def parseurl (s)
4149	(let (type url) (tokens s)		4995	(let (type url) (tokens s)
4150	(let (base args) (tokens url #\?)		4996	(let (base args) (tokens url #\?)
4151	(list (coerce (downcase type) 'sym)	<>	4997	(list (sym (downcase type))
4152	(coerce (subseq base 1) 'sym)		4998	(sym (cut base 1))
4153	(if args	=	4999	(if args
4154	(parseargs args)		5000	(parseargs args)
4155	nil)))))		5001	nil)))))
4156			5002
4157	; don't urldecode field names or anything in cookies; correct?	<>	5003	; I don't urldecode field names or anything in cookies; correct?
4158		=	5004
4159	(def parseargs (s)		5005	(def parseargs (s)
4160	(map (fn ((k v)) (list k (urldecode v)))		5006	(map (fn ((k v)) (list k (urldecode v)))
4161	(map [tokens _ #\=] (tokens s #\&))))		5007	(map [tokens _ #\=] (tokens s #\&))))
4162			5008
4163	(def parsecookies (s)		5009	(def parsecookies (s)
4164	(map [tokens _ #\=]		5010	(map [tokens _ #\=]
4165	(cdr (tokens s [or (whitec _) (is _ #\;)]))))		5011	(cdr (tokens s [or (whitec _) (is _ #\;)]))))
4166			5012
4167	(def arg (req key) (alref (req 'args) key))	<>	5013	(def arg (req key) (alref req!args key))
4168		=	5014
4169	; *** Warning: does not currently urlencode args, so if need to do		5015	; *** Warning: does not currently urlencode args, so if need to do
4170	; that replace v with (urlencode v).		5016	; that replace v with (urlencode v).
4171			5017
4172	(def reassemble-args (req)		5018	(def reassemble-args (req)
4173	(aif (req 'args)	<>	5019	(aif req!args
4174	(apply string "?" (intersperse '&	=	5020	(apply string "?" (intersperse '&
4175	(map (fn (pair)	<>	5021	(map (fn ((k v))
4176	(let (k v) pair
4177	(string k '= v)))		5022	(string k '= v))
4178	it)))	=	5023	it)))
4179	""))		5024	""))
4180			5025
4181	(= fns* (table) fnids* nil timed-fnids* nil)		5026	(= fns* (table) fnids* nil timed-fnids* nil)
4182			5027
4183	; count on huge (expt 64 10) size of fnid space to avoid clashes		5028	; count on huge (expt 64 10) size of fnid space to avoid clashes
4184			5029
4185	(def new-fnid ()		5030	(def new-fnid ()
4186	(let key (sym (rand-string 10))	<>	5031	(check (sym (rand-string 10)) ~fns* (new-fnid)))
4187	(if (fns* key)
4188	(new-fnid)
4189	key)))
4190		=	5032
4191	(def fnid (f)		5033	(def fnid (f)
4192	(atlet key (new-fnid)		5034	(atlet key (new-fnid)
4193	(= (fns* key) f)		5035	(= (fns* key) f)
4194	(push key fnids*)		5036	(push key fnids*)
4195	key))		5037	key))
4196			5038
4197	(def timed-fnid (lasts f)		5039	(def timed-fnid (lasts f)
4198	(atlet key (new-fnid)		5040	(atlet key (new-fnid)
4199	(= (fns* key) f)		5041	(= (fns* key) f)
4200	(push (list key (seconds) lasts) timed-fnids*)		5042	(push (list key (seconds) lasts) timed-fnids*)
4201	key))		5043	key))
4202			5044
4203	; Within f, it will be bound to the fn's own fnid. Remember that this is		5045	; Within f, it will be bound to the fn's own fnid. Remember that this is
4204	; so low-level that need to generate the newline to separate from the headers		5046	; so low-level that need to generate the newline to separate from the headers
4205	; within the body of f.		5047	; within the body of f.
4206			5048
4207	(mac afnid (f)		5049	(mac afnid (f)
4208	`(atlet it (new-fnid)		5050	`(atlet it (new-fnid)
4209	(= (fns* it) ,f)		5051	(= (fns* it) ,f)
4210	(push it fnids*)		5052	(push it fnids*)
4211	it))		5053	it))
4212			5054
4213	;(defop test-afnid req		5055	;(defop test-afnid req
4214	; (tag (a href (url-for (afnid (fn (req) (prn) (pr "my fnid is " it)))))		5056	; (tag (a href (url-for (afnid (fn (req) (prn) (pr "my fnid is " it)))))
4215	; (pr "click here")))		5057	; (pr "click here")))
4216			5058
4217	; To be more sophisticated, instead of killing fnids, could first		5059	; To be more sophisticated, instead of killing fnids, could first
4218	; replace them with fns that tell the server it's harvesting too		5060	; replace them with fns that tell the server it's harvesting too
4219	; aggressively if they start to get called. But the right thing to		5061	; aggressively if they start to get called. But the right thing to
4220	; do is estimate what the max no of fnids can be and set the harvest		5062	; do is estimate what the max no of fnids can be and set the harvest
4221	; limit there-- beyond that the only solution is to buy more memory.		5063	; limit there-- beyond that the only solution is to buy more memory.
4222			5064
4223	(def harvest-fnids ((o n 20000))	<>	5065	(def harvest-fnids ((o n 50000)) ; was 20000
4224	(when (> (len fns*) n)		5066	(when (len> fns* n)
4225	(atomic
4226	(pull (fn ((id created lasts))		5067	(pull (fn ((id created lasts))
4227	(when (> (- (seconds) created) lasts)		5068	(when (> (since created) lasts)
4228	(nil! (fns* id))		5069	(wipe (fns* id))
4229	t))		5070	t))
4230	timed-fnids*))		5071	timed-fnids*)
4231	(atlet nharvest (truncate (/ n 10))		5072	(atlet nharvest (trunc (/ n 10))
4232	(let (kill keep) (splitn nharvest (rev fnids*))		5073	(let (kill keep) (split (rev fnids*) nharvest)
4233	(= fnids* (rev keep))	=	5074	(= fnids* (rev keep))
4234	(each id kill		5075	(each id kill
4235	(nil! (fns* id)))))))	<>	5076	(wipe (fns* id)))))))
4236		=	5077
4237	(= fnurl* "x" rfnurl* "r" rfnurl2* "y" jfnurl* "a")	<>	5078	(= fnurl* "/x" rfnurl* "/r" rfnurl2* "/y" jfnurl* "/a")
			5079
			5080	(= dead-msg* "\nUnknown or expired link.")
4238		=	5081
4239	(defop-raw x (str req)		5082	(defop-raw x (str req)
		<>	5083	(w/stdout str
4240	(let id (sym (arg req "fnid"))		5084	(aif (fns* (sym (arg req "fnid")))
4241	(aif (fns* id)
4242	(w/stdout str (it req))		5085	(it req)
4243	(w/stdout str (prn) (pr "unknown or expired link")))))		5086	(pr dead-msg*))))
4244		=	5087
4245	(defopr-raw y (str req)		5088	(defopr-raw y (str req)
4246	(let id (sym (arg req "fnid"))	<>	5089	(aif (fns* (sym (arg req "fnid")))
4247	(aif (fns* id)
4248	(w/stdout str (it req))		5090	(w/stdout str (it req))
4249	"deadlink")))		5091	"deadlink"))
4250		=	5092
4251	; For asynchronous calls; discards the page. Would be better to tell		5093	; For asynchronous calls; discards the page. Would be better to tell
4252	; the fn not to generate it.		5094	; the fn not to generate it.
4253			5095
4254	(defop-raw a (str req)		5096	(defop-raw a (str req)
4255	(let id (sym (arg req "fnid"))	<>	5097	(aif (fns* (sym (arg req "fnid")))
4256	(aif (fns* id) (tostring (it req)))))		5098	(tostring (it req))))
4257		=	5099
4258	(defopr r req		5100	(defopr r req
4259	(let id (sym (arg req "fnid"))	<>	5101	(aif (fns* (sym (arg req "fnid")))
4260	(aif (fns* id)
4261	(it req)		5102	(it req)
4262	"deadlink")))		5103	"deadlink"))
4263		=	5104
4264	(defop deadlink req		5105	(defop deadlink req
4265	(pr "unknown or expired link"))	<>	5106	(pr dead-msg*))
4266		=	5107
4267	(def url-for (fnid)		5108	(def url-for (fnid)
4268	(string fnurl* "?fnid=" fnid))		5109	(string fnurl* "?fnid=" fnid))
4269			5110
4270	(def flink (f)		5111	(def flink (f)
4271	(string fnurl* "?fnid=" (fnid (fn (req) (prn) (f req)))))		5112	(string fnurl* "?fnid=" (fnid (fn (req) (prn) (f req)))))
4272			5113
4273	; couldn't I just say (fnid f) here?	+-
4274
4275	(def rflink (f)	=	5114	(def rflink (f)
4276	(string rfnurl* "?fnid=" (fnid (fn (req) (f req)))))	<>	5115	(string rfnurl* "?fnid=" (fnid f)))
4277		=	5116
4278	; Since it's just an expr, gensym a parm for (ignored) args.		5117	; Since it's just an expr, gensym a parm for (ignored) args.
4279			5118
4280	(mac w/link (expr . body)		5119	(mac w/link (expr . body)
4281	(w/uniq g	<>
4282	`(tag (a href (flink (fn (,g) ,expr)))		5120	`(tag (a href (flink (fn (,(uniq)) ,expr)))
4283	,@body)))		5121	,@body))
4284		=	5122
4285	(mac w/rlink (expr . body)		5123	(mac w/rlink (expr . body)
4286	(w/uniq g	<>
4287	`(tag (a href (rflink (fn (,g) ,expr)))		5124	`(tag (a href (rflink (fn (,(uniq)) ,expr)))
4288	,@body)))		5125	,@body))
4289		=	5126
4290	(mac onlink (text . body)		5127	(mac onlink (text . body)
4291	`(w/link (do ,@body) (pr ,text)))		5128	`(w/link (do ,@body) (pr ,text)))
		-+	5129
			5130	(mac onrlink (text . body)
			5131	`(w/rlink (do ,@body) (pr ,text)))
4292		=	5132
4293	; bad to have both flink and linkf; rename flink something like fnid-link		5133	; bad to have both flink and linkf; rename flink something like fnid-link
4294			5134
4295	(mac linkf (text parms . body)		5135	(mac linkf (text parms . body)
4296	`(tag (a href (flink (fn ,parms ,@body))) (pr ,text)))		5136	`(tag (a href (flink (fn ,parms ,@body))) (pr ,text)))
4297			5137
4298	(mac rlinkf (text parms . body)		5138	(mac rlinkf (text parms . body)
4299	`(tag (a href (rflink (fn ,parms ,@body))) (pr ,text)))		5139	`(tag (a href (rflink (fn ,parms ,@body))) (pr ,text)))
4300			5140
4301	;(defop top req (linkf 'whoami? (req) (pr "I am " (get-user req))))		5141	;(defop top req (linkf 'whoami? (req) (pr "I am " (get-user req))))
4302			5142
4303	;(defop testf req (w/link (pr "ha ha ha") (pr "laugh")))		5143	;(defop testf req (w/link (pr "ha ha ha") (pr "laugh")))
4304			5144
4305	(mac w/link-if (test expr . body)		5145	(mac w/link-if (test expr . body)
4306	(w/uniq g	<>
4307	`(tag-if ,test (a href (flink (fn (,g) ,expr)))		5146	`(tag-if ,test (a href (flink (fn (,(uniq)) ,expr)))
4308	,@body)))		5147	,@body))
4309		=	5148
		-+	5149	(def fnid-field (id)
			5150	(gentag input type 'hidden name 'fnid value id))
			5151
4310	; f should be a fn of one arg, which will be http request args.	=	5152	; f should be a fn of one arg, which will be http request args.
		-+	5153
			5154	(def fnform (f bodyfn (o redir))
			5155	(tag (form method 'post action (if redir rfnurl2* fnurl*))
			5156	(fnid-field (fnid f))
			5157	(bodyfn)))
			5158
4311	; Could also make a version that uses just an expr, and var capture.	=	5159	; Could also make a version that uses just an expr, and var capture.
4312	; Is there a way to ensure user doesn't use "fnid" as a key?		5160	; Is there a way to ensure user doesn't use "fnid" as a key?
4313			5161
4314	(mac aform (f . body)		5162	(mac aform (f . body)
4315	(w/uniq (gi ga)	<>	5163	(w/uniq ga
			5164	`(tag (form method 'post action fnurl*)
4316	`(let ,gi (fnid (fn (,ga)		5165	(fnid-field (fnid (fn (,ga)
4317	(prn)		5166	(prn)
4318	(,f ,ga)))		5167	(,f ,ga))))
4319	(tag (form method 'post action fnurl*)
4320	(gentag input type 'hidden name 'fnid value ,gi)
4321	,@body))))		5168	,@body)))
4322		=	5169
		-+	5170	;(defop test1 req
			5171	; (fnform (fn (req) (prn) (pr req))
			5172	; (fn () (single-input "" 'foo 20 "submit"))))
			5173
			5174	;(defop test2 req
			5175	; (aform (fn (req) (pr req))
			5176	; (single-input "" 'foo 20 "submit")))
			5177
4323	; Like aform except creates a fnid that will last for lasts seconds	=	5178	; Like aform except creates a fnid that will last for lasts seconds
4324	; (unless the server is restarted).		5179	; (unless the server is restarted).
4325			5180
4326	(mac timed-aform (lasts f . body)	<>	5181	(mac taform (lasts f . body)
4327	(w/uniq (gl gf gi ga)	=	5182	(w/uniq (gl gf gi ga)
4328	`(withs (,gl ,lasts		5183	`(withs (,gl ,lasts
4329	,gf (fn (,ga) (prn) (,f ,ga))	<>	5184	,gf (fn (,ga) (prn) (,f ,ga)))
4330	,gi (if ,gl (timed-fnid ,lasts ,gf) (fnid ,gf)))
4331	(tag (form method 'post action fnurl*)	=	5185	(tag (form method 'post action fnurl*)
4332	(gentag input type 'hidden name 'fnid value ,gi)	<>	5186	(fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
4333	,@body))))	=	5187	,@body))))
4334			5188
4335	(mac arform (f . body)		5189	(mac arform (f . body)
		<>	5190	`(tag (form method 'post action rfnurl*)
			5191	(fnid-field (fnid ,f))
			5192	,@body))
			5193
			5194	; overlong
			5195
			5196	(mac tarform (lasts f . body)
4336	(w/uniq gi		5197	(w/uniq (gl gf)
4337	`(let ,gi (fnid ,f)		5198	`(withs (,gl ,lasts ,gf ,f)
4338	(tag (form method 'post action rfnurl*)	=	5199	(tag (form method 'post action rfnurl*)
4339	(gentag input type 'hidden name 'fnid value ,gi)	<>	5200	(fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
4340	,@body))))	=	5201	,@body))))
4341			5202
4342	(mac aformh (f . body)		5203	(mac aformh (f . body)
4343	(w/uniq gi	<>
4344	`(let ,gi (fnid ,f)
4345	(tag (form method 'post action fnurl*)		5204	`(tag (form method 'post action fnurl*)
4346	(gentag input type 'hidden name 'fnid value ,gi)		5205	(fnid-field (fnid ,f))
4347	,@body))))		5206	,@body))
4348		=	5207
4349	(mac arformh (f . body)		5208	(mac arformh (f . body)
4350	(w/uniq gi	<>
4351	`(let ,gi (fnid ,f)
4352	(tag (form method 'post action rfnurl2*)		5209	`(tag (form method 'post action rfnurl2*)
4353	(gentag input type 'hidden name 'fnid value ,gi)		5210	(fnid-field (fnid ,f))
4354	,@body))))		5211	,@body))
4355		=	5212
4356	; only unique per server invocation		5213	; only unique per server invocation
4357			5214
4358	(= unique-ids* (table))		5215	(= unique-ids* (table))
4359			5216
4360	(def unique-id ((o len 8))		5217	(def unique-id ((o len 8))
4361	(let id (sym (rand-string (max 5 len)))		5218	(let id (sym (rand-string (max 5 len)))
4362	(if (unique-ids* id)		5219	(if (unique-ids* id)
4363	(unique-id)		5220	(unique-id)
4364	(= (unique-ids* id) id))))		5221	(= (unique-ids* id) id))))
4365			5222
4366		+-
4367	(def srvlog (type . args)	=	5223	(def srvlog (type . args)
4368	(w/appendfile o (string logdir* type "-" (memodate))	<>	5224	(w/appendfile o (logfile-name type)
4369	(w/stdout o (apply prs (seconds) args) (prn))))		5225	(w/stdout o (atomic (apply prs (seconds) args) (prn)))))
4370		=	5226
		-+	5227	(def logfile-name (type)
			5228	(string logdir* type "-" (memodate)))
			5229
4371	(with (lastasked nil lastval nil)	=	5230	(with (lastasked nil lastval nil)
4372			5231
4373	(def memodate ()		5232	(def memodate ()
4374	(let now (seconds)		5233	(let now (seconds)
4375	(if (or (no lastasked) (> (- now lastasked) 60))		5234	(if (or (no lastasked) (> (- now lastasked) 60))
4376	(= lastasked now lastval (date))	<>	5235	(= lastasked now lastval (datestring))
4377	lastval)))	=	5236	lastval)))
4378			5237
4379	)		5238	)
4380			5239
4381	(defop \|\| req	<>
4382	(pr "It's alive."))		5240	(defop \|\| req (pr "It's alive."))
4383		=	5241
4384	(defop topips req		5242	(defop topips req
4385	(when (admin (get-user req))		5243	(when (admin (get-user req))
4386	(whitepage		5244	(whitepage
4387	(spacetable	<>	5245	(sptab
4388	(each ip (let leaders nil	=	5246	(each ip (let leaders nil
4389	(maptable (fn (ip n)		5247	(maptable (fn (ip n)
4390	(when (> n 100)		5248	(when (> n 100)
4391	(insort (compare > requests/ip*)		5249	(insort (compare > requests/ip*)
4392	ip		5250	ip
4393	leaders)))		5251	leaders)))
4394	requests/ip*)		5252	requests/ip*)
4395	leaders)		5253	leaders)
4396	(let n (requests/ip* ip)		5254	(let n (requests/ip* ip)
4397	(row ip n (num (* 100 (/ n requests*)) 1))))))))	<>	5255	(row ip n (pr (num (* 100 (/ n requests*)) 1)))))))))
4398		=	5256
		<>	5257	(defop spurned req
4399	(def ensure-install ()		5258	(when (admin (get-user req))
			5259	(whitepage
			5260	(sptab
			5261	(map (fn ((ip n)) (row ip n))
			5262	(sortable spurned*))))))
4400	(ensure-dir arcdir*)		5263
			5264	; eventually promote to general util
4401	(ensure-dir logdir*)		5265
			5266	(def sortable (ht (o f >))
			5267	(let res nil
			5268	(maptable (fn kv
			5269	(insort (compare f cadr) kv res))
			5270	ht)
			5271	res))
4402	(when (empty hpasswords*)		5272
4403	(create-acct "frug" "frug")		5273
			5274	; Background Threads
4404	(writefile1 'frug adminfile*))		5275
			5276	(= bgthreads* (table) pending-bgthreads* nil)
4405	(load-userinfo))		5277
			5278	(def new-bgthread (id f sec)
			5279	(aif (bgthreads* id) (break-thread it))
			5280	(= (bgthreads* id) (new-thread (fn ()
			5281	(while t
			5282	(sleep sec)
			5283	(f))))))
4406		=	5284
		-+	5285	; should be a macro for this?
			5286
			5287	(mac defbg (id sec . body)
			5288	`(do (pull [caris _ ',id] pending-bgthreads*)
			5289	(push (list ',id (fn () ,@body) ,sec)
			5290	pending-bgthreads*)))
			5291
			5292
			5293
			5294	; Idea: make form fields that know their value type because of
			5295	; gensymed names, and so the receiving fn gets args that are not
			5296	; strings but parsed values.
4407		=	5297
4408			5298
4409	./strings.arc		5299	./strings.arc
4410	; Matching. Spun off 29 Jul 06.		5300	; Matching. Spun off 29 Jul 06.
4411			5301
4412	; Arc> (tostring (writec (coerce 133 'char)))	<>	5302	; arc> (tostring (writec (coerce 133 'char)))
4413	;	=	5303	;
4414	;> (define ss (open-output-string))		5304	;> (define ss (open-output-string))
4415	;> (write-char (integer->char 133) ss)		5305	;> (write-char (integer->char 133) ss)
4416	;> (get-output-string ss)		5306	;> (get-output-string ss)
4417	;"\u0085"		5307	;"\u0085"
4418			5308
4419	(def tokens (s (o sep whitec))		5309	(def tokens (s (o sep whitec))
4420	(let test (if (isa sep 'fn) sep (fn (c) (is c sep)))	<>	5310	(let test (testify sep)
4421	(let rec (afn (cs toks tok)	=	5311	(let rec (afn (cs toks tok)
4422	(if (no cs) (consif tok toks)		5312	(if (no cs) (consif tok toks)
4423	(test (car cs)) (self (cdr cs) (consif tok toks) nil)		5313	(test (car cs)) (self (cdr cs) (consif tok toks) nil)
4424	(self (cdr cs) toks (cons (car cs) tok))))		5314	(self (cdr cs) toks (cons (car cs) tok))))
4425	(rev (map [coerce _ 'string]	<>	5315	(rev (map [coerce _ 'string]
4426	(map rev (rec (coerce s 'cons) nil nil)))))))		5316	(map rev (rec (coerce s 'cons) nil nil)))))))
4427		=	5317
		-+	5318	; names of cut, split, halve not optimal
			5319
			5320	(def halve (s (o sep whitec))
			5321	(let test (testify sep)
			5322	(let rec (afn (cs tok)
			5323	(if (no cs) (list (rev tok))
			5324	(test (car cs)) (list cs (rev tok))
			5325	(self (cdr cs) (cons (car cs) tok))))
			5326	(rev (map [coerce _ 'string]
			5327	(rec (coerce s 'cons) nil))))))
			5328
			5329	; maybe promote to arc.arc, but if so include a list clause
			5330
			5331	(def positions (test seq)
			5332	(accum a
			5333	(let f (testify test)
			5334	(forlen i seq
			5335	(if (f (seq i)) (a i))))))
			5336
			5337	(def lines (s)
			5338	(accum a
			5339	((afn ((p . ps))
			5340	(if ps
			5341	(do (a (rem #\return (cut s (+ p 1) (car ps))))
			5342	(self ps))
			5343	(a (cut s (+ p 1)))))
			5344	(cons -1 (positions #\newline s)))))
			5345
			5346	(def slices (s test)
			5347	(accum a
			5348	((afn ((p . ps))
			5349	(if ps
			5350	(do (a (cut s (+ p 1) (car ps)))
			5351	(self ps))
			5352	(a (cut s (+ p 1)))))
			5353	(cons -1 (positions test s)))))
			5354
4428	; > (require (lib "uri-codec.ss" "net"))	=	5355	; > (require (lib "uri-codec.ss" "net"))
4429	;> (form-urlencoded-decode "x%ce%bbx")		5356	;> (form-urlencoded-decode "x%ce%bbx")
4430	;"xλx"		5357	;"xλx"
4431			5358
4432	; first byte: 0-7F, 1 char; c2-df 2; e0-ef 3, f0-f4 4.		5359	; first byte: 0-7F, 1 char; c2-df 2; e0-ef 3, f0-f4 4.
4433			5360
		-+	5361	; Fixed for utf8 by pc.
			5362
4434	(def urldecode (s)	=	5363	(def urldecode (s)
4435	(tostring	<>	5364	(tostring
4436	(forlen i s		5365	(forlen i s
4437	(caselet c (s i)		5366	(caselet c (s i)
4438	#\+ (writec #\space)		5367	#\+ (writec #\space)
4439	#\% (do (when (> (- (len s) i) 2)		5368	#\% (do (when (> (- (len s) i) 2)
4440	(let code (coerce (subseq s (+ i 1) (+ i 3))		5369	(writeb (int (cut s (+ i 1) (+ i 3)) 16)))
4441	'int 16)
4442	(if (> code 126)
4443	(pr (latin1-hack code))
4444	(writec (coerce code 'char)))))
4445	(++ i 2))		5370	(++ i 2))
4446	(writec c)))))		5371	(writec c)))))
4447		=	5372
4448		<>	5373	(def urlencode (s)
4449	; Converts utf8 chars between 128 and 255 to ascii char or string.
4450	; Not able to convert every char; generates X if can't. Probably not
4451	; the ultimate solution. The Right Thing would be to preserve these
4452	; chars, instead of downgrading them to ascii. To do that, would have
4453	; to convert them to unicode. E.g. ellipsis in unicode is #x2026,
4454	; euro sign is #x20ac.
4455			5374	(tostring
4456	; In Mzscheme: (display (integer->char #xE9))
4457			5375	(each c s
4458	; Then have to figure out how to print them back out, both in forms
4459	; and in pages. Presumably do the reverse translation and &-escape them.
4460			5376	(writec #\%)
4461	; For much of this range, unicode and utf8 agree. 233 is e-acute in
4462	; both. It's chars like 133 that are a problem. So perhaps as a
4463	; start try preserving e.g. 233.
4464			5377	(let i (int c)
4465	; This would be faster if I made a macro that translated it into
4466	; a hashtable or even string.
4467			5378	(if (< i 16) (writec #\0))
4468	(def latin1-hack (i)
4469	(if (is i 128) "EUR" ; euros
4470	(is i 133) "..."
4471	(<= 145 i 146) #\'
4472	(<= 147 i 148) #\"
4473	(is i 151) "--" ; long dash
4474	(is i 154) #\S
4475	(is i 155) #\>
4476	(is i 156) "oe"
4477	(is i 158) #\z
4478	(is i 159) #\Y
4479	(is i 162) #\c ; cents		5379	(pr (coerce i 'string 16))))))
4480	(is i 163) "GBP" ; pounds
4481	(is i 165) "JPY" ; yen
4482	(is i 166) #\\|
4483	(is i 171) "<<"
4484	(is i 187) ">>"
4485	(<= 192 i 197) #\A
4486	(is i 198) "AE"
4487	(is i 199) #\C
4488	(<= 200 i 203) #\E
4489	(<= 204 i 207) #\I
4490	(is i 209) #\N
4491	(<= 210 i 214) #\O
4492	(is i 215) #\x
4493	(is i 216) #\O
4494	(<= 217 i 220) #\U
4495	(is i 221) #\Y
4496	(is i 223) "ss"
4497	(<= 224 i 229) #\a
4498	(is i 230) "ae"
4499	(is i 231) #\c
4500	(<= 232 i 235) #\e
4501	(<= 236 i 239) #\i
4502	(is i 241) #\n
4503	(<= 242 i 246) #\o
4504	(is i 247) #\/
4505	(is i 248) #\o
4506	(<= 249 i 252) #\u
4507	(in i 253 255) #\y
4508	#\X
4509	))
4510		=	5380
4511	(mac litmatch (pat string (o start 0))		5381	(mac litmatch (pat string (o start 0))
4512	(w/uniq (gstring gstart)		5382	(w/uniq (gstring gstart)
4513	`(with (,gstring ,string ,gstart ,start)		5383	`(with (,gstring ,string ,gstart ,start)
4514	(unless (> (+ ,gstart ,(len pat)) (len ,gstring))		5384	(unless (> (+ ,gstart ,(len pat)) (len ,gstring))
4515	(and ,@(let acc nil		5385	(and ,@(let acc nil
4516	(forlen i pat		5386	(forlen i pat
4517	(push `(is ,(pat i) (,gstring (+ ,gstart ,i)))		5387	(push `(is ,(pat i) (,gstring (+ ,gstart ,i)))
4518	acc))		5388	acc))
4519	(rev acc)))))))		5389	(rev acc)))))))
4520			5390
4521	; litmatch would be cleaner if map worked for string and integer args:		5391	; litmatch would be cleaner if map worked for string and integer args:
4522			5392
4523	; ,@(map (fn (n c)		5393	; ,@(map (fn (n c)
4524	; `(is ,c (,gstring (+ ,gstart ,n))))		5394	; `(is ,c (,gstring (+ ,gstart ,n))))
4525	; (len pat)		5395	; (len pat)
4526	; pat)		5396	; pat)
4527			5397
4528	(mac endmatch (pat string)		5398	(mac endmatch (pat string)
4529	(w/uniq (gstring glen)		5399	(w/uniq (gstring glen)
4530	`(withs (,gstring ,string ,glen (len ,gstring))		5400	`(withs (,gstring ,string ,glen (len ,gstring))
4531	(unless (> ,(len pat) (len ,gstring))		5401	(unless (> ,(len pat) (len ,gstring))
4532	(and ,@(let acc nil		5402	(and ,@(let acc nil
4533	(forlen i pat		5403	(forlen i pat
4534	(push `(is ,(pat (- (len pat) 1 i))		5404	(push `(is ,(pat (- (len pat) 1 i))
4535	(,gstring (- ,glen 1 ,i)))		5405	(,gstring (- ,glen 1 ,i)))
4536	acc))		5406	acc))
4537	(rev acc)))))))		5407	(rev acc)))))))
4538			5408
4539	(def posmatch (pat seq (o start 0))		5409	(def posmatch (pat seq (o start 0))
4540	(catch		5410	(catch
4541	(if (isa pat 'fn)		5411	(if (isa pat 'fn)
4542	(for i start (- (len seq) 1)		5412	(for i start (- (len seq) 1)
4543	(when (pat (seq i)) (throw i)))		5413	(when (pat (seq i)) (throw i)))
4544	(for i start (- (len seq) (- (len pat) 2))	<>	5414	(for i start (- (len seq) (len pat))
4545	(when (headmatch pat seq i) (throw i))))	=	5415	(when (headmatch pat seq i) (throw i))))
4546	nil))		5416	nil))
4547			5417
4548	(def headmatch (pat seq (o start 0))		5418	(def headmatch (pat seq (o start 0))
4549	(let p (len pat)		5419	(let p (len pat)
4550	((afn (i)		5420	((afn (i)
4551	(or (is i p)		5421	(or (is i p)
4552	(and (is (pat i) (seq (+ i start)))		5422	(and (is (pat i) (seq (+ i start)))
4553	(self (+ i 1)))))		5423	(self (+ i 1)))))
4554	0)))		5424	0)))
4555			5425
4556	(def begins (seq pat (o start 0))		5426	(def begins (seq pat (o start 0))
4557	(unless (> (len pat) (- (len seq) start))	<>	5427	(unless (len> pat (- (len seq) start))
4558	(headmatch pat seq start)))	=	5428	(headmatch pat seq start)))
4559			5429
4560	(def subst (new old seq)		5430	(def subst (new old seq)
4561	(let boundary (+ (- (len seq) (len old)) 1)		5431	(let boundary (+ (- (len seq) (len old)) 1)
4562	(tostring		5432	(tostring
4563	(forlen i seq		5433	(forlen i seq
4564	(if (and (< i boundary) (headmatch old seq i))		5434	(if (and (< i boundary) (headmatch old seq i))
4565	(do (++ i (- (len old) 1))		5435	(do (++ i (- (len old) 1))
4566	(pr new))		5436	(pr new))
4567	(pr (seq i)))))))		5437	(pr (seq i)))))))
4568			5438
4569	(def multisubst (pairs seq)		5439	(def multisubst (pairs seq)
4570	(tostring		5440	(tostring
4571	(forlen i seq		5441	(forlen i seq
4572	(iflet (old new) (find [begins seq (car _) i] pairs)		5442	(iflet (old new) (find [begins seq (car _) i] pairs)
4573	(do (++ i (- (len old) 1))		5443	(do (++ i (- (len old) 1))
4574	(pr new))		5444	(pr new))
4575	(pr (seq i))))))		5445	(pr (seq i))))))
4576			5446
		-+	5447	; not a good name
			5448
4577	(def findsubseq (pat seq (o start 0))	=	5449	(def findsubseq (pat seq (o start 0))
4578	(if (< (- (len seq) start) (len pat))		5450	(if (< (- (len seq) start) (len pat))
4579	nil		5451	nil
4580	(if (headmatch pat seq start)		5452	(if (headmatch pat seq start)
4581	start		5453	start
4582	(findsubseq pat seq (+ start 1)))))		5454	(findsubseq pat seq (+ start 1)))))
4583			5455
4584	(def blank (s) (~find ~whitec s))		5456	(def blank (s) (~find ~whitec s))
4585			5457
		<>	5458	(def nonblank (s) (unless (blank s) s))
4586	; should make it possible for test to be a literal as well		5459
4587			5460	(def trim (s (o where 'both) (o test whitec))
4588	(def trim (s where (o test whitec))		5461	(withs (f (testify test)
4589	(let p1 (pos [no (test _)] s)		5462	p1 (pos ~f s))
4590	(if p1	=	5463	(if p1
4591	(subseq s	<>	5464	(cut s
4592	(if (in where 'front 'both) p1 0)		5465	(if (in where 'front 'both) p1 0)
4593	(when (in where 'end 'both)		5466	(when (in where 'end 'both)
4594	(let i (- (len s) 1)		5467	(let i (- (len s) 1)
4595	(while (and (> i p1) (test (s i)))		5468	(while (and (> i p1) (f (s i)))
4596	(-- i))		5469	(-- i))
4597	(+ i 1))))		5470	(+ i 1))))
4598	"")))	=	5471	"")))
4599			5472
4600	(def num (m (o digits 2) (o trail-zeros nil) (o init-zero nil))	<>	5473	(def num (n (o digits 2) (o trail-zeros nil) (o init-zero nil))
4601	(let comma		5474	(withs (comma
4602	(fn (n)		5475	(fn (i)
4603	(tostring		5476	(tostring
4604	(map [apply pr (rev _)]		5477	(map [apply pr (rev _)]
4605	(rev (intersperse '(#\,)		5478	(rev (intersperse '(#\,)
4606	(tuples (rev (coerce (string n) 'cons))		5479	(tuples (rev (coerce (string i) 'cons))
4607	3))))))		5480	3))))))
			5481	abrep
			5482	(let a (abs n)
4608	(if (< digits 1)		5483	(if (< digits 1)
4609	(comma (roundup m))		5484	(comma (roundup a))
4610	(exact m)		5485	(exact a)
4611	(string (comma m)		5486	(string (comma a)
4612	(when (and trail-zeros (> digits 0))		5487	(when (and trail-zeros (> digits 0))
4613	(string "." (newstring digits #\0))))		5488	(string "." (newstring digits #\0))))
			5489	(withs (d (expt 10 digits)
			5490	m (/ (roundup (* a d)) d)
4614	(let n (truncate m)		5491	i (trunc m)
			5492	r (abs (trunc (- (* m d) (* i d)))))
			5493	(+ (if (is i 0)
4615	(string (if (is n 0) (if init-zero 0 "") (comma n))		5494	(if (or init-zero (is r 0)) "0" "")
4616	"."		5495	(comma i))
4617	(withs (rest (string (abs (roundup		5496	(withs (rest (string r)
4618	(- (* m (expt 10 digits))
4619	(* n (expt 10 digits))))))
4620	v2 (string (newstring (- digits (len rest)) #\0)		5497	padded (+ (newstring (- digits (len rest)) #\0)
4621	rest))		5498	rest)
4622	(if trail-zeros		5499	final (if trail-zeros
			5500	padded
			5501	(trim padded 'end [is _ #\0])))
			5502	(string (unless (empty final) ".")
			5503	final)))))))
			5504	(if (and (< n 0) (find [and (digit _) (isnt _ #\0)] abrep))
			5505	(+ "-" abrep)
			5506	abrep)))
			5507
4623	v2		5508
			5509	; English
4624	(trim v2 'end [is _ #\0]))))))))		5510
			5511	(def pluralize (n str)
			5512	(if (or (is n 1) (single n))
			5513	str
			5514	(string str "s")))
4625		=	5515
		-+	5516	(def plural (n x)
			5517	(string n #\ (pluralize n x)))
4626		=	5518
		-+	5519
4627	; http://www.eki.ee/letter/chardata.cgi?HTML4=1	=	5520	; http://www.eki.ee/letter/chardata.cgi?HTML4=1
4628	; http://jrgraphix.net/research/unicode_blocks.php?block=1		5521	; http://jrgraphix.net/research/unicode_blocks.php?block=1
4629	; http://home.tiscali.nl/t876506/utf8tbl.html		5522	; http://home.tiscali.nl/t876506/utf8tbl.html
4630	; http://www.fileformat.info/info/unicode/block/latin_supplement/utf8test.htm		5523	; http://www.fileformat.info/info/unicode/block/latin_supplement/utf8test.htm
4631	; http://en.wikipedia.org/wiki/Utf-8		5524	; http://en.wikipedia.org/wiki/Utf-8
4632	; http://unicode.org/charts/charindex2.html		5525	; http://unicode.org/charts/charindex2.html
4633			5526
		-+	5527	./news.arc
			5528	; News. 2 Sep 06.
			5529
			5530	; to run news: (nsv), then go to http://localhost:8080
			5531	; put usernames of admins, separated by whitespace, in arc/admins
			5532
			5533	; bug: somehow (+ votedir* nil) is getting evaluated.
			5534
			5535	(declare 'atstrings t)
			5536
			5537	(= this-site* "My Forum"
			5538	site-url* "http://news.yourdomain.com/"
			5539	parent-url* "http://www.yourdomain.com"
			5540	favicon-url* ""
			5541	site-desc* "What this site is about." ; for rss feed
			5542	site-color* (color 180 180 180)
			5543	border-color* (color 180 180 180)
			5544	prefer-url* t)
			5545
			5546
			5547	; Structures
			5548
			5549	; Could add (html) types like choice, yesno to profile fields. But not
			5550	; as part of deftem, which is defstruct. Need another mac on top of
			5551	; deftem. Should not need the type specs in user-fields.
			5552
			5553	(deftem profile
			5554	id nil
			5555	name nil
			5556	created (seconds)
			5557	auth 0
			5558	member nil
			5559	submitted nil
			5560	votes nil ; for now just recent, elts each (time id by sitename dir)
			5561	karma 1
			5562	avg nil
			5563	weight .5
			5564	ignore nil
			5565	email nil
			5566	about nil
			5567	showdead nil
			5568	noprocrast nil
			5569	firstview nil
			5570	lastview nil
			5571	maxvisit 20
			5572	minaway 180
			5573	topcolor nil
			5574	keys nil
			5575	delay 0)
			5576
			5577	(deftem item
			5578	id nil
			5579	type nil
			5580	by nil
			5581	ip nil
			5582	time (seconds)
			5583	url nil
			5584	title nil
			5585	text nil
			5586	votes nil ; elts each (time ip user type score)
			5587	score 0
			5588	sockvotes 0
			5589	flags nil
			5590	dead nil
			5591	deleted nil
			5592	parts nil
			5593	parent nil
			5594	kids nil
			5595	keys nil)
			5596
			5597
			5598	; Load and Save
			5599
			5600	(= newsdir* "arc/news/"
			5601	storydir* "arc/news/story/"
			5602	profdir* "arc/news/profile/"
			5603	votedir* "arc/news/vote/")
			5604
			5605	(= votes* (table) profs* (table))
			5606
			5607	(= initload-users* nil)
			5608
			5609	(def nsv ((o port 8080))
			5610	(map ensure-dir (list arcdir* newsdir* storydir* votedir* profdir*))
			5611	(unless stories* (load-items))
			5612	(if (and initload-users* (empty profs*)) (load-users))
			5613	(asv port))
			5614
			5615	(def load-users ()
			5616	(pr "load users: ")
			5617	(noisy-each 100 id (dir profdir*)
			5618	(load-user id)))
			5619
			5620	; For some reason vote files occasionally get written out in a
			5621	; broken way. The nature of the errors (random missing or extra
			5622	; chars) suggests the bug is lower-level than anything in Arc.
			5623	; Which unfortunately means all lists written to disk are probably
			5624	; vulnerable to it, since that's all save-table does.
			5625
			5626	(def load-user (u)
			5627	(= (votes* u) (load-table (+ votedir* u))
			5628	(profs* u) (temload 'profile (+ profdir* u)))
			5629	u)
			5630
			5631	; Have to check goodname because some user ids come from http requests.
			5632	; So this is like safe-item. Don't need a sep fn there though.
			5633
			5634	(def profile (u)
			5635	(or (profs* u)
			5636	(aand (goodname u)
			5637	(file-exists (+ profdir* u))
			5638	(= (profs* u) (temload 'profile it)))))
			5639
			5640	(def votes (u)
			5641	(or (votes* u)
			5642	(aand (file-exists (+ votedir* u))
			5643	(= (votes* u) (load-table it)))))
			5644
			5645	(def init-user (u)
			5646	(= (votes* u) (table)
			5647	(profs* u) (inst 'profile 'id u))
			5648	(save-votes u)
			5649	(save-prof u)
			5650	u)
			5651
			5652	; Need this because can create users on the server (for other apps)
			5653	; without setting up places to store their state as news users.
			5654	; See the admin op in app.arc. So all calls to login-page from the
			5655	; news app need to call this in the after-login fn.
			5656
			5657	(def ensure-news-user (u)
			5658	(if (profile u) u (init-user u)))
			5659
			5660	(def save-votes (u) (save-table (votes* u) (+ votedir* u)))
			5661
			5662	(def save-prof (u) (save-table (profs* u) (+ profdir* u)))
			5663
			5664	(mac uvar (u k) `((profile ,u) ',k))
			5665
			5666	(mac karma (u) `(uvar ,u karma))
			5667	(mac ignored (u) `(uvar ,u ignore))
			5668
			5669	; Note that users will now only consider currently loaded users.
			5670
			5671	(def users ((o f idfn))
			5672	(keep f (keys profs*)))
			5673
			5674	(def check-key (u k)
			5675	(and u (mem k (uvar u keys))))
			5676
			5677	(def author (u i) (is u i!by))
			5678
			5679
			5680	(= stories* nil comments* nil
			5681	items* (table) url->story* (table)
			5682	maxid* 0 initload* 15000)
			5683
			5684	; The dir expression yields stories in order of file creation time
			5685	; (because arc infile truncates), so could just rev the list instead of
			5686	; sorting, but sort anyway.
			5687
			5688	; Note that stories* etc only include the initloaded (i.e. recent)
			5689	; ones, plus those created since this server process started.
			5690
			5691	; Could be smarter about preloading by keeping track of popular pages.
			5692
			5693	(def load-items ()
			5694	(system (+ "rm " storydir* "*.tmp"))
			5695	(pr "load items: ")
			5696	(with (items (table)
			5697	ids (sort > (map int (dir storydir*))))
			5698	(if ids (= maxid* (car ids)))
			5699	(noisy-each 100 id (firstn initload* ids)
			5700	(let i (load-item id)
			5701	(push i (items i!type))))
			5702	(= stories* (rev (merge (compare < !id) items!story items!poll))
			5703	comments* (rev items!comment))
			5704	(hook 'initload items))
			5705	(ensure-topstories))
			5706
			5707	(def ensure-topstories ()
			5708	(aif (errsafe (readfile1 (+ newsdir* "topstories")))
			5709	(= ranked-stories* (map item it))
			5710	(do (prn "ranking stories.")
			5711	(flushout)
			5712	(gen-topstories))))
			5713
			5714	(def astory (i) (is i!type 'story))
			5715	(def acomment (i) (is i!type 'comment))
			5716	(def apoll (i) (is i!type 'poll))
			5717
			5718	(def load-item (id)
			5719	(let i (temload 'item (+ storydir* id))
			5720	(= (items* id) i)
			5721	(awhen (and (astory&live i) (check i!url ~blank))
			5722	(register-url i it))
			5723	i))
			5724
			5725	; Note that duplicates are only prevented of items that have at some
			5726	; point been loaded.
			5727
			5728	(def register-url (i url)
			5729	(= (url->story* (canonical-url url)) i!id))
			5730
			5731	; redefined later
			5732
			5733	(= stemmable-sites* (table))
			5734
			5735	(def canonical-url (url)
			5736	(if (stemmable-sites* (sitename url))
			5737	(cut url 0 (pos #\? url))
			5738	url))
			5739
			5740	(def new-item-id ()
			5741	(evtil (++ maxid) [~file-exists (+ storydir _)]))
			5742
			5743	(def item (id)
			5744	(or (items* id) (errsafe:load-item id)))
			5745
			5746	(def kids (i) (map item i!kids))
			5747
			5748	; For use on external item references (from urls). Checks id is int
			5749	; because people try e.g. item?id=363/blank.php
			5750
			5751	(def safe-item (id)
			5752	(ok-id&item (if (isa id 'string) (saferead id) id)))
			5753
			5754	(def ok-id (id)
			5755	(and (exact id) (<= 1 id maxid*)))
			5756
			5757	(def arg->item (req key)
			5758	(safe-item:saferead (arg req key)))
			5759
			5760	(def live (i) (nor i!dead i!deleted))
			5761
			5762	(def save-item (i) (save-table i (+ storydir* i!id)))
			5763
			5764	(def kill (i how)
			5765	(unless i!dead
			5766	(log-kill i how)
			5767	(wipe (comment-cache* i!id))
			5768	(set i!dead)
			5769	(save-item i)))
			5770
			5771	(= kill-log* nil)
			5772
			5773	(def log-kill (i how)
			5774	(push (list i!id how) kill-log*))
			5775
			5776	(mac each-loaded-item (var . body)
			5777	(w/uniq g
			5778	`(let ,g nil
			5779	(loop (= ,g maxid*) (> ,g 0) (-- ,g)
			5780	(whenlet ,var (items* ,g)
			5781	,@body)))))
			5782
			5783	(def loaded-items (test)
			5784	(accum a (each-loaded-item i (test&a i))))
			5785
			5786	(def newslog args (apply srvlog 'news args))
			5787
			5788
			5789	; Ranking
			5790
			5791	; Votes divided by the age in hours to the gravityth power.
			5792	; Would be interesting to scale gravity in a slider.
			5793
			5794	(= gravity* 1.8 timebase* 120 front-threshold* 1
			5795	nourl-factor* .4 lightweight-factor* .3 )
			5796
			5797	(def frontpage-rank (s (o scorefn realscore) (o gravity gravity*))
			5798	(* (/ (let base (- (scorefn s) 1)
			5799	(if (> base 0) (expt base .8) base))
			5800	(expt (/ (+ (item-age s) timebase*) 60) gravity))
			5801	(if (no (in s!type 'story 'poll)) .5
			5802	(blank s!url) nourl-factor*
			5803	(lightweight s) (min lightweight-factor*
			5804	(contro-factor s))
			5805	(contro-factor s))))
			5806
			5807	(def contro-factor (s)
			5808	(aif (check (visible-family nil s) [> _ 20])
			5809	(min 1 (expt (/ (realscore s) it) 2))
			5810	1))
			5811
			5812	(def realscore (i) (- i!score i!sockvotes))
			5813
			5814	(disktable lightweights* (+ newsdir* "lightweights"))
			5815
			5816	(def lightweight (s)
			5817	(or s!dead
			5818	(mem 'rally s!keys) ; title is a rallying cry
			5819	(mem 'image s!keys) ; post is mainly image(s)
			5820	(lightweights* (sitename s!url))
			5821	(lightweight-url s!url)))
			5822
			5823	(defmemo lightweight-url (url)
			5824	(in (downcase (last (tokens url #\.))) "png" "jpg" "jpeg"))
			5825
			5826	(def item-age (i) (minutes-since i!time))
			5827
			5828	(def user-age (u) (minutes-since (uvar u created)))
			5829
			5830	; Only looks at the 1000 most recent stories, which might one day be a
			5831	; problem if there is massive spam.
			5832
			5833	(def gen-topstories ()
			5834	(= ranked-stories* (rank-stories 180 1000 (memo frontpage-rank))))
			5835
			5836	(def save-topstories ()
			5837	(writefile (map !id (firstn 180 ranked-stories*))
			5838	(+ newsdir* "topstories")))
			5839
			5840	(def rank-stories (n consider scorefn)
			5841	(bestn n (compare > scorefn) (latest-items metastory nil consider)))
			5842
			5843	; With virtual lists the above call to latest-items could be simply:
			5844	; (map item (retrieve consider metastory:item (gen maxid* [- _ 1])))
			5845
			5846	(def latest-items (test (o stop) (o n))
			5847	(accum a
			5848	(catch
			5849	(down id maxid* 1
			5850	(let i (item id)
			5851	(if (or (and stop (stop i)) (and n (<= n 0)))
			5852	(throw))
			5853	(when (test i)
			5854	(a i)
			5855	(if n (-- n))))))))
			5856
			5857	; redefined later
			5858
			5859	(def metastory (i) (and i (in i!type 'story 'poll)))
			5860
			5861	(def adjust-rank (s (o scorefn frontpage-rank))
			5862	(insortnew (compare > (memo scorefn)) s ranked-stories*)
			5863	(save-topstories))
			5864
			5865	; If something rose high then stopped getting votes, its score would
			5866	; decline but it would stay near the top. Newly inserted stories would
			5867	; thus get stuck in front of it. I avoid this by regularly adjusting
			5868	; the rank of a random top story.
			5869
			5870	(defbg rerank-random 30 (rerank-random))
			5871
			5872	(def rerank-random ()
			5873	(when ranked-stories*
			5874	(adjust-rank (ranked-stories* (rand (min 50 (len ranked-stories*)))))))
			5875
			5876	(def topstories (user n (o threshold front-threshold*))
			5877	(retrieve n
			5878	[and (>= (realscore _) threshold) (cansee user _)]
			5879	ranked-stories*))
			5880
			5881	(= max-delay* 10)
			5882
			5883	(def cansee (user i)
			5884	(if i!deleted (admin user)
			5885	i!dead (or (author user i) (seesdead user))
			5886	(delayed i) (author user i)
			5887	t))
			5888
			5889	(let mature (table)
			5890	(def delayed (i)
			5891	(and (no (mature i!id))
			5892	(acomment i)
			5893	(or (< (item-age i) (min max-delay* (uvar i!by delay)))
			5894	(do (set (mature i!id))
			5895	nil)))))
			5896
			5897	(def seesdead (user)
			5898	(or (and user (uvar user showdead) (no (ignored user)))
			5899	(editor user)))
			5900
			5901	(def visible (user is)
			5902	(keep [cansee user _] is))
			5903
			5904	(def cansee-descendant (user c)
			5905	(or (cansee user c)
			5906	(some [cansee-descendant user (item _)]
			5907	c!kids)))
			5908
			5909	(def editor (u)
			5910	(and u (or (admin u) (> (uvar u auth) 0))))
			5911
			5912	(def member (u)
			5913	(and u (or (admin u) (uvar u member))))
			5914
			5915
			5916	; Page Layout
			5917
			5918	(= up-url* "grayarrow.gif" down-url* "graydown.gif" logo-url* "arc.png")
			5919
			5920	(defopr favicon.ico req favicon-url*)
			5921
			5922	; redefined later
			5923
			5924	(def gen-css-url ()
			5925	(prn "<link rel=\"stylesheet\" type=\"text/css\" href=\"news.css\">"))
			5926
			5927	(mac npage (title . body)
			5928	`(tag html
			5929	(tag head
			5930	(gen-css-url)
			5931	(prn "<link rel=\"shortcut icon\" href=\"" favicon-url* "\">")
			5932	(tag script (pr votejs*))
			5933	(tag title (pr ,title)))
			5934	(tag body
			5935	(center
			5936	(tag (table border 0 cellpadding 0 cellspacing 0 width "85%"
			5937	bgcolor sand)
			5938	,@body)))))
			5939
			5940	(= pagefns* nil)
			5941
			5942	(mac fulltop (user lid label title whence . body)
			5943	(w/uniq (gu gi gl gt gw)
			5944	`(with (,gu ,user ,gi ,lid ,gl ,label ,gt ,title ,gw ,whence)
			5945	(npage (+ this-site* (if ,gt (+ bar* ,gt) ""))
			5946	(if (check-procrast ,gu)
			5947	(do (pagetop 'full ,gi ,gl ,gt ,gu ,gw)
			5948	(hook 'page ,gu ,gl)
			5949	,@body)
			5950	(row (procrast-msg ,gu ,gw)))))))
			5951
			5952	(mac longpage (user t1 lid label title whence . body)
			5953	(w/uniq (gu gt gi)
			5954	`(with (,gu ,user ,gt ,t1 ,gi ,lid)
			5955	(fulltop ,gu ,gi ,label ,title ,whence
			5956	(trtd ,@body)
			5957	(trtd (vspace 10)
			5958	(color-stripe (main-color ,gu))
			5959	(br)
			5960	(center
			5961	(hook 'longfoot)
			5962	(admin-bar ,gu (- (msec) ,gt) ,whence)))))))
			5963
			5964	(def admin-bar (user elapsed whence)
			5965	(when (admin user)
			5966	(br2)
			5967	(w/bars
			5968	(pr (len items) "/" maxid " loaded")
			5969	(pr (round (/ (memory) 1000000)) " mb")
			5970	(pr elapsed " msec")
			5971	(link "settings" "newsadmin")
			5972	(hook 'admin-bar user whence))))
			5973
			5974	(def color-stripe (c)
			5975	(tag (table width "100%" cellspacing 0 cellpadding 1)
			5976	(tr (tdcolor c))))
			5977
			5978	(mac shortpage (user lid label title whence . body)
			5979	`(fulltop ,user ,lid ,label ,title ,whence
			5980	(trtd ,@body)))
			5981
			5982	(mac minipage (label . body)
			5983	`(npage (+ this-site* bar* ,label)
			5984	(pagetop nil nil ,label)
			5985	(trtd ,@body)))
			5986
			5987	(def msgpage (user msg (o title))
			5988	(minipage (or title "Message")
			5989	(spanclass admin
			5990	(center (if (len> msg 80)
			5991	(widtable 500 msg)
			5992	(pr msg))))
			5993	(br2)))
			5994
			5995	(= (max-age* 'news.css) 86400) ; cache css in browser for 1 day
			5996
			5997	; turn off server caching via (= caching* 0) or won't see changes
			5998
			5999	(defop news.css req
			6000	(pr "
			6001	body { font-family:Verdana; font-size:10pt; color:#828282; }
			6002	td { font-family:Verdana; font-size:10pt; color:#828282; }
			6003
			6004	.admin td { font-family:Verdana; font-size:8.5pt; color:#000000; }
			6005	.subtext td { font-family:Verdana; font-size: 7pt; color:#828282; }
			6006
			6007	input { font-family:Courier; font-size:10pt; color:#000000; }
			6008	input[type=\"submit\"] { font-family:Verdana; }
			6009	textarea { font-family:Courier; font-size:10pt; color:#000000; }
			6010
			6011	a:link { color:#000000; text-decoration:none; }
			6012	a:visited { color:#828282; text-decoration:none; }
			6013
			6014	.default { font-family:Verdana; font-size: 10pt; color:#828282; }
			6015	.admin { font-family:Verdana; font-size:8.5pt; color:#000000; }
			6016	.title { font-family:Verdana; font-size: 10pt; color:#828282; }
			6017	.adtitle { font-family:Verdana; font-size: 9pt; color:#828282; }
			6018	.subtext { font-family:Verdana; font-size: 7pt; color:#828282; }
			6019	.yclinks { font-family:Verdana; font-size: 8pt; color:#828282; }
			6020	.pagetop { font-family:Verdana; font-size: 10pt; color:#222222; }
			6021	.comhead { font-family:Verdana; font-size: 8pt; color:#828282; }
			6022	.comment { font-family:Verdana; font-size: 9pt; }
			6023	.dead { font-family:Verdana; font-size: 9pt; color:#dddddd; }
			6024
			6025	.comment a:link, .comment a:visited { text-decoration:underline;}
			6026	.dead a:link, .dead a:visited { color:#dddddd; }
			6027	.pagetop a:visited { color:#000000;}
			6028	.topsel a:link, .topsel a:visited { color:#ffffff; }
			6029
			6030	.subtext a:link, .subtext a:visited { color:#828282; }
			6031	.subtext a:hover { text-decoration:underline; }
			6032
			6033	.comhead a:link, .subtext a:visited { color:#828282; }
			6034	.comhead a:hover { text-decoration:underline; }
			6035
			6036	.default p { margin-top: 8px; margin-bottom: 0px; }
			6037
			6038	.pagebreak {page-break-before:always}
			6039
			6040	pre { overflow: auto; padding: 2px; max-width:600px; }
			6041	pre:hover {overflow:auto} "))
			6042
			6043	; only need pre padding because of a bug in Mac Firefox
			6044
			6045	; Without setting the bottom margin of p tags to 0, 1- and n-para comments
			6046	; have different space at the bottom. This solution suggested by Devin.
			6047	; Really am using p tags wrong (as separators rather than wrappers) and the
			6048	; correct thing to do would be to wrap each para in <p></p>. Then whatever
			6049	; I set the bottom spacing to, it would be the same no matter how many paras
			6050	; in a comment. In this case by setting the bottom spacing of p to 0, I'm
			6051	; making it the same as no p, which is what the first para has.
			6052
			6053	; supplied by pb
			6054	;.vote { padding-left:2px; vertical-align:top; }
			6055	;.comment { margin-top:1ex; margin-bottom:1ex; color:black; }
			6056	;.vote IMG { border:0; margin: 3px 2px 3px 2px; }
			6057	;.reply { font-size:smaller; text-decoration:underline !important; }
			6058
			6059	(= votejs* "
			6060	function byId(id) {
			6061	return document.getElementById(id);
			6062	}
			6063
			6064	function vote(node) {
			6065	var v = node.id.split(/_/); // {'up', '123'}
			6066	var item = v[1];
			6067
			6068	// adjust score
			6069	var score = byId('score_' + item);
			6070	var newscore = parseInt(score.innerHTML) + (v[0] == 'up' ? 1 : -1);
			6071	score.innerHTML = newscore + (newscore == 1 ? ' point' : ' points');
			6072
			6073	// hide arrows
			6074	byId('up_' + item).style.visibility = 'hidden';
			6075	byId('down_' + item).style.visibility = 'hidden';
			6076
			6077	// ping server
			6078	var ping = new Image();
			6079	ping.src = node.href;
			6080
			6081	return false; // cancel browser nav
			6082	} ")
			6083
			6084
			6085	; Page top
			6086
			6087	(= sand (color 246 246 239) textgray (gray 130))
			6088
			6089	(def main-color (user)
			6090	(aif (and user (uvar user topcolor))
			6091	(hex>color it)
			6092	site-color*))
			6093
			6094	(def pagetop (switch lid label (o title) (o user) (o whence))
			6095	; (tr (tdcolor black (vspace 5)))
			6096	(tr (tdcolor (main-color user)
			6097	(tag (table border 0 cellpadding 0 cellspacing 0 width "100%"
			6098	style "padding:2px")
			6099	(tr (gen-logo)
			6100	(when (is switch 'full)
			6101	(tag (td style "line-height:12pt; height:10px;")
			6102	(spanclass pagetop
			6103	(tag b (link this-site* "news"))
			6104	(hspace 10)
			6105	(toprow user label))))
			6106	(if (is switch 'full)
			6107	(tag (td style "text-align:right;padding-right:4px;")
			6108	(spanclass pagetop (topright user whence)))
			6109	(tag (td style "line-height:12pt; height:10px;")
			6110	(spanclass pagetop (prbold label))))))))
			6111	(map [_ user] pagefns*)
			6112	(spacerow 10))
			6113
			6114	(def gen-logo ()
			6115	(tag (td style "width:18px;padding-right:4px")
			6116	(tag (a href parent-url*)
			6117	(tag (img src logo-url* width 18 height 18
			6118	style "border:1px #@(hexrep border-color*) solid;")))))
			6119
			6120	(= toplabels* '(nil "welcome" "new" "threads" "comments" "leaders" "*"))
			6121
			6122	; redefined later
			6123
			6124	(= welcome-url* "welcome")
			6125
			6126	(def toprow (user label)
			6127	(w/bars
			6128	(when (noob user)
			6129	(toplink "welcome" welcome-url* label))
			6130	(toplink "new" "newest" label)
			6131	(when user
			6132	(toplink "threads" (threads-url user) label))
			6133	(toplink "comments" "newcomments" label)
			6134	(toplink "leaders" "leaders" label)
			6135	(hook 'toprow user label)
			6136	(link "submit")
			6137	(unless (mem label toplabels*)
			6138	(fontcolor white (pr label)))))
			6139
			6140	(def toplink (name dest label)
			6141	(tag-if (is name label) (span class 'topsel)
			6142	(link name dest)))
			6143
			6144	(def topright (user whence (o showkarma t))
			6145	(when user
			6146	(userlink user user nil)
			6147	(when showkarma (pr " (@(karma user))"))
			6148	(pr " \| "))
			6149	(if user
			6150	(rlinkf 'logout (req)
			6151	(when-umatch/r user req
			6152	(logout-user user)
			6153	whence))
			6154	(onlink "login"
			6155	(login-page 'both nil
			6156	(list (fn (u ip)
			6157	(ensure-news-user u)
			6158	(newslog ip u 'top-login))
			6159	whence)))))
			6160
			6161	(def noob (user)
			6162	(and user (< (days-since (uvar user created)) 1)))
			6163
			6164
			6165	; News-Specific Defop Variants
			6166
			6167	(mac defopt (name parm test msg . body)
			6168	`(defop ,name ,parm
			6169	(if (,test (get-user ,parm))
			6170	(do ,@body)
			6171	(login-page 'both (+ "Please log in" ,msg ".")
			6172	(list (fn (u ip) (ensure-news-user u))
			6173	(string ',name (reassemble-args ,parm)))))))
			6174
			6175	(mac defopg (name parm . body)
			6176	`(defopt ,name ,parm idfn "" ,@body))
			6177
			6178	(mac defope (name parm . body)
			6179	`(defopt ,name ,parm editor " as an editor" ,@body))
			6180
			6181	(mac defopa (name parm . body)
			6182	`(defopt ,name ,parm admin " as an administrator" ,@body))
			6183
			6184	(mac opexpand (definer name parms . body)
			6185	(w/uniq gr
			6186	`(,definer ,name ,gr
			6187	(with (user (get-user ,gr) ip (,gr 'ip))
			6188	(with ,(and parms (mappend [list _ (list 'arg gr (string _))]
			6189	parms))
			6190	(newslog ip user ',name ,@parms)
			6191	,@body)))))
			6192
			6193	(= newsop-names* nil)
			6194
			6195	(mac newsop args
			6196	`(do (pushnew ',(car args) newsop-names*)
			6197	(opexpand defop ,@args)))
			6198
			6199	(mac adop (name parms . body)
			6200	(w/uniq g
			6201	`(opexpand defopa ,name ,parms
			6202	(let ,g (string ',name)
			6203	(shortpage user nil ,g ,g ,g
			6204	,@body)))))
			6205
			6206	(mac edop (name parms . body)
			6207	(w/uniq g
			6208	`(opexpand defope ,name ,parms
			6209	(let ,g (string ',name)
			6210	(shortpage user nil ,g ,g ,g
			6211	,@body)))))
			6212
			6213
			6214	; News Admin
			6215
			6216	(defopa newsadmin req
			6217	(let user (get-user req)
			6218	(newslog req!ip user 'newsadmin)
			6219	(newsadmin-page user)))
			6220
			6221	; Note that caching* is reset to val in source when restart server.
			6222
			6223	(def nad-fields ()
			6224	`((num caching ,caching* t t)
			6225	(bigtoks comment-kill ,comment-kill* t t)
			6226	(bigtoks comment-ignore ,comment-ignore* t t)
			6227	(bigtoks lightweights ,(sort < (keys lightweights*)) t t)))
			6228
			6229	; Need a util like vars-form for a collection of variables.
			6230	; Or could generalize vars-form to think of places (in the setf sense).
			6231
			6232	(def newsadmin-page (user)
			6233	(shortpage user nil nil "newsadmin" "newsadmin"
			6234	(vars-form user
			6235	(nad-fields)
			6236	(fn (name val)
			6237	(case name
			6238	caching (= caching* val)
			6239	comment-kill (todisk comment-kill* val)
			6240	comment-ignore (todisk comment-ignore* val)
			6241	lightweights (todisk lightweights* (memtable val))
			6242	))
			6243	(fn () (newsadmin-page user)))
			6244	(br2)
			6245	(aform (fn (req)
			6246	(with (user (get-user req) subject (arg req "id"))
			6247	(if (profile subject)
			6248	(do (killallby subject)
			6249	(submitted-page user subject))
			6250	(admin&newsadmin-page user))))
			6251	(single-input "" 'id 20 "kill all by"))
			6252	(br2)
			6253	(aform (fn (req)
			6254	(let user (get-user req)
			6255	(set-ip-ban user (arg req "ip") t)
			6256	(admin&newsadmin-page user)))
			6257	(single-input "" 'ip 20 "ban ip"))))
			6258
			6259
			6260	; Users
			6261
			6262	(newsop user (id)
			6263	(if (only.profile id)
			6264	(user-page user id)
			6265	(pr "No such user.")))
			6266
			6267	(def user-page (user subject)
			6268	(let here (user-url subject)
			6269	(shortpage user nil nil (+ "Profile: " subject) here
			6270	(profile-form user subject)
			6271	(br2)
			6272	(when (some astory:item (uvar subject submitted))
			6273	(underlink "submissions" (submitted-url subject)))
			6274	(when (some acomment:item (uvar subject submitted))
			6275	(sp)
			6276	(underlink "comments" (threads-url subject)))
			6277	(hook 'user user subject))))
			6278
			6279	(def profile-form (user subject)
			6280	(let prof (profile subject)
			6281	(vars-form user
			6282	(user-fields user subject)
			6283	(fn (name val)
			6284	(when (and (is name 'ignore) val (no prof!ignore))
			6285	(log-ignore user subject 'profile))
			6286	(= (prof name) val))
			6287	(fn () (save-prof subject)
			6288	(user-page user subject)))))
			6289
			6290	(= topcolor-threshold* 250)
			6291
			6292	(def user-fields (user subject)
			6293	(withs (e (editor user)
			6294	a (admin user)
			6295	w (is user subject)
			6296	k (and w (> (karma user) topcolor-threshold*))
			6297	u (or a w)
			6298	m (or a (and (member user) w))
			6299	p (profile subject))
			6300	`((string user ,subject t nil)
			6301	(string name ,(p 'name) ,m ,m)
			6302	(string created ,(text-age:user-age subject) t nil)
			6303	(string password ,(resetpw-link) ,w nil)
			6304	(string saved ,(saved-link user subject) ,u nil)
			6305	(int auth ,(p 'auth) ,e ,a)
			6306	(yesno member ,(p 'member) ,a ,a)
			6307	(posint karma ,(p 'karma) t ,a)
			6308	(num avg ,(p 'avg) ,a nil)
			6309	(yesno ignore ,(p 'ignore) ,e ,e)
			6310	(num weight ,(p 'weight) ,a ,a)
			6311	(mdtext2 about ,(p 'about) t ,u)
			6312	(string email ,(p 'email) ,u ,u)
			6313	(yesno showdead ,(p 'showdead) ,u ,u)
			6314	(yesno noprocrast ,(p 'noprocrast) ,u ,u)
			6315	(string firstview ,(p 'firstview) ,a nil)
			6316	(string lastview ,(p 'lastview) ,a nil)
			6317	(posint maxvisit ,(p 'maxvisit) ,u ,u)
			6318	(posint minaway ,(p 'minaway) ,u ,u)
			6319	(sexpr keys ,(p 'keys) ,a ,a)
			6320	(hexcol topcolor ,(or (p 'topcolor) (hexrep site-color*)) ,k ,k)
			6321	(int delay ,(p 'delay) ,u ,u))))
			6322
			6323	(def saved-link (user subject)
			6324	(when (or (admin user) (is user subject))
			6325	(let n (if (len> (votes subject) 500)
			6326	"many"
			6327	(len (voted-stories user subject)))
			6328	(if (is n 0)
			6329	""
			6330	(tostring (underlink n (saved-url subject)))))))
			6331
			6332	(def resetpw-link ()
			6333	(tostring (underlink "reset password" "resetpw")))
			6334
			6335	(newsop welcome ()
			6336	(pr "Welcome to " this-site* ", " user "!"))
			6337
			6338
			6339	; Main Operators
			6340
			6341	; remember to set caching to 0 when testing non-logged-in
			6342
			6343	(= caching* 1 perpage* 30 threads-perpage* 10 maxend* 210)
			6344
			6345	; Limiting that newscache can't take any arguments except the user.
			6346	; To allow other arguments, would have to turn the cache from a single
			6347	; stored value to a hash table whose keys were lists of arguments.
			6348
			6349	(mac newscache (name user time . body)
			6350	(w/uniq gc
			6351	`(let ,gc (cache (fn () (* caching* ,time))
			6352	(fn () (tostring (let ,user nil ,@body))))
			6353	(def ,name (,user)
			6354	(if ,user
			6355	(do ,@body)
			6356	(pr (,gc)))))))
			6357
			6358
			6359	(newsop news () (newspage user))
			6360
			6361	(newsop \|\| () (newspage user))
			6362
			6363	;(newsop index.html () (newspage user))
			6364
			6365	(newscache newspage user 90
			6366	(listpage user (msec) (topstories user maxend*) nil nil "news"))
			6367
			6368	(def listpage (user t1 items label title (o url label) (o number t))
			6369	(hook 'listpage user)
			6370	(longpage user t1 nil label title url
			6371	(display-items user items label title url 0 perpage* number)))
			6372
			6373
			6374	(newsop newest () (newestpage user))
			6375
			6376	; Note: dead/deleted items will persist for the remaining life of the
			6377	; cached page. If this were a prob, could make deletion clear caches.
			6378
			6379	(newscache newestpage user 40
			6380	(listpage user (msec) (newstories user maxend*) "new" "New Links" "newest"))
			6381
			6382	(def newstories (user n)
			6383	(retrieve n [cansee user _] stories*))
			6384
			6385
			6386	(newsop best () (bestpage user))
			6387
			6388	(newscache bestpage user 1000
			6389	(listpage user (msec) (beststories user maxend*) "best" "Top Links"))
			6390
			6391	; As no of stories gets huge, could test visibility in fn sent to best.
			6392
			6393	(def beststories (user n)
			6394	(bestn n (compare > realscore) (visible user stories*)))
			6395
			6396
			6397	(newsop noobstories () (noobspage user stories*))
			6398	(newsop noobcomments () (noobspage user comments*))
			6399
			6400	(def noobspage (user source)
			6401	(listpage user (msec) (noobs user maxend* source) "noobs" "New Accounts"))
			6402
			6403	(def noobs (user n source)
			6404	(retrieve n [and (cansee user _) (bynoob _)] source))
			6405
			6406	(def bynoob (i)
			6407	(< (- (user-age i!by) (item-age i)) 2880))
			6408
			6409
			6410	(newsop bestcomments () (bestcpage user))
			6411
			6412	(newscache bestcpage user 1000
			6413	(listpage user (msec) (bestcomments user maxend*)
			6414	"best comments" "Best Comments" "bestcomments" nil))
			6415
			6416	(def bestcomments (user n)
			6417	(bestn n (compare > realscore) (visible user comments*)))
			6418
			6419
			6420	(newsop lists ()
			6421	(longpage user (msec) nil "lists" "Lists" "lists"
			6422	(sptab
			6423	(row (link "best") "Highest voted recent links.")
			6424	(row (link "active") "Most active current discussions.")
			6425	(row (link "bestcomments") "Highest voted recent comments.")
			6426	(row (link "noobstories") "Submissions from new accounts.")
			6427	(row (link "noobcomments") "Comments from new accounts.")
			6428	(when (admin user)
			6429	(map row:link
			6430	'(optimes topips flagged killed badguys badlogins goodlogins)))
			6431	(hook 'listspage user))))
			6432
			6433
			6434	(def saved-url (user) (+ "saved?id=" user))
			6435
			6436	(newsop saved (id)
			6437	(if (only.profile id)
			6438	(savedpage user id)
			6439	(pr "No such user.")))
			6440
			6441	(def savedpage (user subject)
			6442	(if (or (is user subject) (admin user))
			6443	(listpage user (msec)
			6444	(sort (compare < item-age) (voted-stories user subject))
			6445	"saved" "Saved Links" (saved-url subject))
			6446	(pr "Can't display that.")))
			6447
			6448	(def voted-stories (user subject)
			6449	(keep [and (astory _) (cansee user _)]
			6450	(map item (keys:votes subject))))
			6451
			6452
			6453	; Story Display
			6454
			6455	(def display-items (user items label title whence
			6456	(o start 0) (o end perpage*) (o number))
			6457	(zerotable
			6458	(let n start
			6459	(each i (cut items start end)
			6460	(display-item (and number (++ n)) i user whence t)
			6461	(spacerow (if (acomment i) 15 5))))
			6462	(when end
			6463	(let newend (+ end perpage*)
			6464	(when (and (<= newend maxend*) (< end (len items)))
			6465	(spacerow 10)
			6466	(tr (tag (td colspan (if number 2 1)))
			6467	(tag (td class 'title)
			6468	(morelink display-items
			6469	items label title end newend number))))))))
			6470
			6471	; This code is inevitably complex because the More fn needs to know
			6472	; its own fnid in order to supply a correct whence arg to stuff on
			6473	; the page it generates, like logout and delete links.
			6474
			6475	(def morelink (f items label title . args)
			6476	(tag (a href
			6477	(url-for
			6478	(afnid (fn (req)
			6479	(prn)
			6480	(with (url (url-for it) ; it bound by afnid
			6481	user (get-user req))
			6482	(newslog req!ip user 'more label)
			6483	(longpage user (msec) nil label title url
			6484	(apply f user items label title url args))))))
			6485	rel 'nofollow)
			6486	(pr "More")))
			6487
			6488	(def display-story (i s user whence)
			6489	(when (or (cansee user s) (s 'kids))
			6490	(tr (display-item-number i)
			6491	(td (votelinks s user whence))
			6492	(titleline s s!url user whence))
			6493	(tr (tag (td colspan (if i 2 1)))
			6494	(tag (td class 'subtext)
			6495	(hook 'itemline s user)
			6496	(itemline s user)
			6497	(when (in s!type 'story 'poll) (commentlink s user))
			6498	(editlink s user)
			6499	(when (apoll s) (addoptlink s user))
			6500	(unless i (flaglink s user whence))
			6501	(killlink s user whence)
			6502	(blastlink s user whence)
			6503	(blastlink s user whence t)
			6504	(deletelink s user whence)))))
			6505
			6506	(def display-item-number (i)
			6507	(when i (tag (td align 'right valign 'top class 'title)
			6508	(pr i "."))))
			6509
			6510	(= follow-threshold* 5)
			6511
			6512	(def titleline (s url user whence)
			6513	(tag (td class 'title)
			6514	(if (cansee user s)
			6515	(do (deadmark s user)
			6516	(titlelink s url user)
			6517	(pdflink url)
			6518	(awhen (sitename url)
			6519	(spanclass comhead
			6520	(pr " (" )
			6521	(if (admin user)
			6522	(w/rlink (do (set-site-ban user
			6523	it
			6524	(case (car (banned-sites* it))
			6525	nil 'ignore
			6526	ignore 'kill
			6527	kill nil))
			6528	whence)
			6529	(let ban (car (banned-sites* it))
			6530	(tag-if ban (font color (case ban
			6531	ignore darkred
			6532	kill darkblue))
			6533	(pr it))))
			6534	(pr it))
			6535	(pr ") "))))
			6536	(pr (pseudo-text s)))))
			6537
			6538	(def titlelink (s url user)
			6539	(let toself (blank url)
			6540	(tag (a href (if toself
			6541	(item-url s!id)
			6542	(or (live s) (author user s) (editor user))
			6543	url
			6544	nil)
			6545	rel (unless (or toself (> (realscore s) follow-threshold*))
			6546	'nofollow))
			6547	(pr s!title))))
			6548
			6549	(def pdflink (url)
			6550	(awhen (vacuumize url)
			6551	(pr " [")
			6552	(link "scribd" it)
			6553	(pr "]")))
			6554
			6555	(defmemo vacuumize (url)
			6556	(and (or (endmatch ".pdf" url) (endmatch ".PDF" url))
			6557	(+ "http://www.scribd.com/vacuum?url=" url)))
			6558
			6559	(def pseudo-text (i)
			6560	(if i!deleted "[deleted]" "[dead]"))
			6561
			6562	(def deadmark (i user)
			6563	(when (and i!dead (seesdead user))
			6564	(pr " [dead] "))
			6565	(when (and i!deleted (admin user))
			6566	(pr " [deleted] ")))
			6567
			6568	(= downvote-threshold* 200 downvote-time* 1440)
			6569
			6570	(= votewid* 14)
			6571
			6572	(def votelinks (i user whence (o downtoo))
			6573	(center
			6574	(if (and (cansee user i)
			6575	(or (no user)
			6576	(no ((votes user) i!id))))
			6577	(do (votelink i user whence 'up)
			6578	(if (and downtoo
			6579	(or (admin user)
			6580	(< (item-age i) downvote-time*))
			6581	(canvote user i 'down))
			6582	(do (br)
			6583	(votelink i user whence 'down))
			6584	; don't understand why needed, but is, or a new
			6585	; page is generated on voting
			6586	(tag (span id (+ "down_" i!id)))))
			6587	(author user i)
			6588	(do (fontcolor orange (pr "*"))
			6589	(br)
			6590	(hspace votewid*))
			6591	(hspace votewid*))))
			6592
			6593	; could memoize votelink more, esp for non-logged in users,
			6594	; since only uparrow is shown; could straight memoize
			6595
			6596	; redefined later (identically) so the outs catch new vals of up-url, etc.
			6597
			6598	(def votelink (i user whence dir)
			6599	(tag (a id (if user (string dir '_ i!id))
			6600	onclick (if user "return vote(this)")
			6601	href (vote-url user i dir whence))
			6602	(if (is dir 'up)
			6603	(out (gentag img src up-url* border 0 vspace 3 hspace 2))
			6604	(out (gentag img src down-url* border 0 vspace 3 hspace 2)))))
			6605
			6606	(def vote-url (user i dir whence)
			6607	(+ "vote?" "for=" i!id
			6608	"&dir=" dir
			6609	(if user (+ "&by=" user "&auth=" (user->cookie* user)))
			6610	"&whence=" (urlencode whence)))
			6611
			6612	(= lowest-score* -4)
			6613
			6614	; Not much stricter than whether to generate the arrow. Further tests
			6615	; applied in vote-for.
			6616
			6617	(def canvote (user i dir)
			6618	(and user
			6619	(news-type&live i)
			6620	(or (is dir 'up) (> i!score lowest-score*))
			6621	(no ((votes user) i!id))
			6622	(or (is dir 'up)
			6623	(and (acomment i)
			6624	(> (karma user) downvote-threshold*)
			6625	(no (aand i!parent (author user (item it))))))))
			6626
			6627	; Need the by argument or someone could trick logged in users into
			6628	; voting something up by clicking on a link. But a bad guy doesn't
			6629	; know how to generate an auth arg that matches each user's cookie.
			6630
			6631	(newsop vote (by for dir auth whence)
			6632	(with (i (safe-item for)
			6633	dir (saferead dir)
			6634	whence (if whence (urldecode whence) "news"))
			6635	(if (no i)
			6636	(pr "No such item.")
			6637	(no (in dir 'up 'down))
			6638	(pr "Can't make that vote.")
			6639	(and by (or (isnt by user) (isnt (sym auth) (user->cookie* user))))
			6640	(pr "User mismatch.")
			6641	(no user)
			6642	(login-page 'both "You have to be logged in to vote."
			6643	(list (fn (u ip)
			6644	(ensure-news-user u)
			6645	(newslog ip u 'vote-login)
			6646	(when (canvote u i dir)
			6647	(vote-for u i dir)
			6648	(logvote ip u i)))
			6649	whence))
			6650	(canvote user i dir)
			6651	(do (vote-for by i dir)
			6652	(logvote ip by i))
			6653	(pr "Can't make that vote."))))
			6654
			6655	(def itemline (i user)
			6656	(when (cansee user i)
			6657	(when (news-type i) (itemscore i user))
			6658	(byline i user)))
			6659
			6660	(def itemscore (i (o user))
			6661	(tag (span id (+ "score_" i!id))
			6662	(pr (plural (if (is i!type 'pollopt) (realscore i) i!score)
			6663	"point")))
			6664	(hook 'itemscore i user))
			6665
			6666	; redefined later
			6667
			6668	(def byline (i user)
			6669	(pr " by @(tostring (userlink user i!by)) @(text-age:item-age i) "))
			6670
			6671	(def user-url (user) (+ "user?id=" user))
			6672
			6673	(= show-avg* nil)
			6674
			6675	(def userlink (user subject (o show-avg t))
			6676	(link (user-name user subject) (user-url subject))
			6677	(awhen (and show-avg* (admin user) show-avg (uvar subject avg))
			6678	(pr " (@(num it 1 t t))")))
			6679
			6680	(= noob-color* (color 60 150 60))
			6681
			6682	(def user-name (user subject)
			6683	(if (and (editor user) (ignored subject))
			6684	(tostring (fontcolor darkred (pr subject)))
			6685	(and (editor user) (< (user-age subject) 1440))
			6686	(tostring (fontcolor noob-color* (pr subject)))
			6687	subject))
			6688
			6689	(= show-threadavg* nil)
			6690
			6691	(def commentlink (i user)
			6692	(when (cansee user i)
			6693	(pr bar*)
			6694	(tag (a href (item-url i!id))
			6695	(let n (- (visible-family user i) 1)
			6696	(if (> n 0)
			6697	(do (pr (plural n "comment"))
			6698	(awhen (and show-threadavg* (admin user) (threadavg i))
			6699	(pr " (@(num it 1 t t))")))
			6700	(pr "discuss"))))))
			6701
			6702	(def visible-family (user i)
			6703	(+ (if (cansee user i) 1 0)
			6704	(sum [visible-family user (item _)] i!kids)))
			6705
			6706	(def threadavg (i)
			6707	(only.avg (map [or (uvar _ avg) 1]
			6708	(rem admin (dedup (map !by (keep live (family i))))))))
			6709
			6710	(= user-changetime* 120 editor-changetime* 1440)
			6711
			6712	(= everchange* (table) noedit* (table))
			6713
			6714	(def canedit (user i)
			6715	(or (admin user)
			6716	(and (~noedit* i!type)
			6717	(editor user)
			6718	(< (item-age i) editor-changetime*))
			6719	(own-changeable-item user i)))
			6720
			6721	(def own-changeable-item (user i)
			6722	(and (author user i)
			6723	(~mem 'locked i!keys)
			6724	(no i!deleted)
			6725	(or (everchange* i!type)
			6726	(< (item-age i) user-changetime*))))
			6727
			6728	(def editlink (i user)
			6729	(when (canedit user i)
			6730	(pr bar*)
			6731	(link "edit" (edit-url i))))
			6732
			6733	(def addoptlink (p user)
			6734	(when (or (admin user) (author user p))
			6735	(pr bar*)
			6736	(onlink "add choice" (add-pollopt-page p user))))
			6737
			6738	; reset later
			6739
			6740	(= flag-threshold* 30 flag-kill-threshold* 7 many-flags* 1)
			6741
			6742	; Un-flagging something doesn't unkill it, if it's now no longer
			6743	; over flag-kill-threshold. Ok, since arbitrary threshold anyway.
			6744
			6745	(def flaglink (i user whence)
			6746	(when (and user
			6747	(isnt user i!by)
			6748	(or (admin user) (> (karma user) flag-threshold*)))
			6749	(pr bar*)
			6750	(w/rlink (do (togglemem user i!flags)
			6751	(when (and (~mem 'nokill i!keys)
			6752	(len> i!flags flag-kill-threshold*)
			6753	(< (realscore i) 10)
			6754	(~find admin:!2 i!vote))
			6755	(kill i 'flags))
			6756	whence)
			6757	(pr "@(if (mem user i!flags) 'un)flag"))
			6758	(when (and (admin user) (len> i!flags many-flags*))
			6759	(pr bar* (plural (len i!flags) "flag") " ")
			6760	(w/rlink (do (togglemem 'nokill i!keys)
			6761	(save-item i)
			6762	whence)
			6763	(pr (if (mem 'nokill i!keys) "un-notice" "noted"))))))
			6764
			6765	(def killlink (i user whence)
			6766	(when (admin user)
			6767	(pr bar*)
			6768	(w/rlink (do (zap no i!dead)
			6769	(if i!dead
			6770	(do (pull 'nokill i!keys)
			6771	(log-kill i user))
			6772	(pushnew 'nokill i!keys))
			6773	(save-item i)
			6774	whence)
			6775	(pr "@(if i!dead 'un)kill"))))
			6776
			6777	; Blast kills the submission and bans the user. Nuke also bans the
			6778	; site, so that all future submitters will be ignored. Does not ban
			6779	; the ip address, but that will eventually get banned by maybe-ban-ip.
			6780
			6781	(def blastlink (i user whence (o nuke))
			6782	(when (and (admin user)
			6783	(or (no nuke) (~empty i!url)))
			6784	(pr bar*)
			6785	(w/rlink (do (toggle-blast i user nuke)
			6786	whence)
			6787	(prt (if (ignored i!by) "un-") (if nuke "nuke" "blast")))))
			6788
			6789	(def toggle-blast (i user (o nuke))
			6790	(atomic
			6791	(if (ignored i!by)
			6792	(do (wipe i!dead (ignored i!by))
			6793	(awhen (and nuke (sitename i!url))
			6794	(set-site-ban user it nil)))
			6795	(do (set i!dead)
			6796	(ignore user i!by (if nuke 'nuke 'blast))
			6797	(awhen (and nuke (sitename i!url))
			6798	(set-site-ban user it 'ignore))))
			6799	(if i!dead (log-kill i user))
			6800	(save-item i)
			6801	(save-prof i!by)))
			6802
			6803	(def candelete (user i)
			6804	(or (admin user) (own-changeable-item user i)))
			6805
			6806	(def deletelink (i user whence)
			6807	(when (candelete user i)
			6808	(pr bar*)
			6809	(linkf (if i!deleted "undelete" "delete") (req)
			6810	(let user (get-user req)
			6811	(if (candelete user i)
			6812	(del-confirm-page user i whence)
			6813	(prn "You can't delete that."))))))
			6814
			6815	; Undeleting stories could cause a slight inconsistency. If a story
			6816	; linking to x gets deleted, another submission can take its place in
			6817	; url->story. If the original is then undeleted, there will be two
			6818	; stories with equal claim to be in url->story. (The more recent will
			6819	; win because it happens to get loaded later.) Not a big problem.
			6820
			6821	(def del-confirm-page (user i whence)
			6822	(minipage "Confirm"
			6823	(tab
			6824	; link never used so not testable but think correct
			6825	(display-item nil i user (flink [del-confirm-page (get-user _) i whence]))
			6826	(spacerow 20)
			6827	(tr (td)
			6828	(td (urform user req
			6829	(do (when (candelete user i)
			6830	(= i!deleted (is (arg req "b") "Yes"))
			6831	(save-item i))
			6832	whence)
			6833	(prn "Do you want this to @(if i!deleted 'stay 'be) deleted?")
			6834	(br2)
			6835	(but "Yes" "b") (sp) (but "No" "b")))))))
			6836
			6837	(def permalink (story user)
			6838	(when (cansee user story)
			6839	(pr bar*)
			6840	(link "link" (item-url story!id))))
			6841
			6842	(def logvote (ip user story)
			6843	(newslog ip user 'vote (story 'id) (list (story 'title))))
			6844
			6845	(def text-age (a)
			6846	(tostring
			6847	(if (>= a 1440) (pr (plural (trunc (/ a 1440)) "day") " ago")
			6848	(>= a 60) (pr (plural (trunc (/ a 60)) "hour") " ago")
			6849	(pr (plural (trunc a) "minute") " ago"))))
			6850
			6851
			6852	; Voting
			6853
			6854	; A user needs legit-threshold karma for a vote to count if there has
			6855	; already been a vote from the same IP address. A new account below both
			6856	; new- thresholds won't affect rankings, though such votes still affect
			6857	; scores unless not a legit-user.
			6858
			6859	(= legit-threshold* 0 new-age-threshold* 0 new-karma-threshold* 2)
			6860
			6861	(def legit-user (user)
			6862	(or (editor user)
			6863	(> (karma user) legit-threshold*)))
			6864
			6865	(def possible-sockpuppet (user)
			6866	(or (ignored user)
			6867	(< (uvar user weight) .5)
			6868	(and (< (user-age user) new-age-threshold*)
			6869	(< (karma user) new-karma-threshold*))))
			6870
			6871	(= downvote-ratio-limit* .65 recent-votes* nil votewindow* 100)
			6872
			6873	; Note: if vote-for by one user changes (s 'score) while s is being
			6874	; edited by another, the save after the edit will overwrite the change.
			6875	; Actual votes can't be lost because that field is not editable. Not a
			6876	; big enough problem to drag in locking.
			6877
			6878	(def vote-for (user i (o dir 'up))
			6879	(unless (or ((votes user) i!id)
			6880	(and (~live i) (isnt user i!by)))
			6881	(withs (ip (logins* user)
			6882	vote (list (seconds) ip user dir i!score))
			6883	(unless (or (and (or (ignored user) (check-key user 'novote))
			6884	(isnt user i!by))
			6885	(and (is dir 'down)
			6886	(~editor user)
			6887	(or (check-key user 'nodowns)
			6888	(> (downvote-ratio user) downvote-ratio-limit*)
			6889	; prevention of karma-bombing
			6890	(just-downvoted user i!by)))
			6891	(and (~legit-user user)
			6892	(isnt user i!by)
			6893	(find [is (cadr _) ip] i!votes))
			6894	(and (isnt i!type 'pollopt)
			6895	(biased-voter i vote)))
			6896	(++ i!score (case dir up 1 down -1))
			6897	; canvote protects against sockpuppet downvote of comments
			6898	(when (and (is dir 'up) (possible-sockpuppet user))
			6899	(++ i!sockvotes))
			6900	(metastory&adjust-rank i)
			6901	(unless (or (author user i)
			6902	(and (is ip i!ip) (~editor user))
			6903	(is i!type 'pollopt))
			6904	(++ (karma i!by) (case dir up 1 down -1))
			6905	(save-prof i!by))
			6906	(wipe (comment-cache* i!id)))
			6907	(if (admin user) (pushnew 'nokill i!keys))
			6908	(push vote i!votes)
			6909	(save-item i)
			6910	(push (list (seconds) i!id i!by (sitename i!url) dir)
			6911	(uvar user votes))
			6912	(= ((votes* user) i!id) vote)
			6913	(save-votes user)
			6914	(zap [firstn votewindow* _] (uvar user votes))
			6915	(save-prof user)
			6916	(push (cons i!id vote) recent-votes*))))
			6917
			6918	; redefined later
			6919
			6920	(def biased-voter (i vote) nil)
			6921
			6922	; ugly to access vote fields by position number
			6923
			6924	(def downvote-ratio (user (o sample 20))
			6925	(ratio [is _.1.3 'down]
			6926	(keep [let by ((item (car _)) 'by)
			6927	(nor (is by user) (ignored by))]
			6928	(bestn sample (compare > car:cadr) (tablist (votes user))))))
			6929
			6930	(def just-downvoted (user victim (o n 3))
			6931	(let prev (firstn n (recent-votes-by user))
			6932	(and (is (len prev) n)
			6933	(all (fn ((id sec ip voter dir score))
			6934	(and (author victim (item id)) (is dir 'down)))
			6935	prev))))
			6936
			6937	; Ugly to pluck out fourth element. Should read votes into a vote
			6938	; template. They're stored slightly differently in two diff places:
			6939	; in one with the voter in the car and the other without.
			6940
			6941	(def recent-votes-by (user)
			6942	(keep [is _.3 user] recent-votes*))
			6943
			6944
			6945	; Story Submission
			6946
			6947	(newsop submit ()
			6948	(if user
			6949	(submit-page user "" "" t)
			6950	(submit-login-warning "" "" t)))
			6951
			6952	(def submit-login-warning ((o url) (o title) (o showtext) (o text))
			6953	(login-page 'both "You have to be logged in to submit."
			6954	(fn (user ip)
			6955	(ensure-news-user user)
			6956	(newslog ip user 'submit-login)
			6957	(submit-page user url title showtext text))))
			6958
			6959	(def submit-page (user (o url) (o title) (o showtext) (o text "") (o msg))
			6960	(minipage "Submit"
			6961	(pagemessage msg)
			6962	(urform user req
			6963	(process-story (get-user req)
			6964	(clean-url (arg req "u"))
			6965	(striptags (arg req "t"))
			6966	showtext
			6967	(and showtext (md-from-form (arg req "x") t))
			6968	req!ip)
			6969	(tab
			6970	(row "title" (input "t" title 50))
			6971	(if prefer-url*
			6972	(do (row "url" (input "u" url 50))
			6973	(when showtext
			6974	(row "" "<b>or</b>")
			6975	(row "text" (textarea "x" 4 50 (only.pr text)))))
			6976	(do (row "text" (textarea "x" 4 50 (only.pr text)))
			6977	(row "" "<b>or</b>")
			6978	(row "url" (input "u" url 50))))
			6979	(row "" (submit))
			6980	(spacerow 20)
			6981	(row "" submit-instructions*)))))
			6982
			6983	(= submit-instructions*
			6984	"Leave url blank to submit a question for discussion. If there is
			6985	no url, the text (if any) will appear at the top of the comments
			6986	page. If there is a url, the text will be ignored.")
			6987
			6988	; For use by outside code like bookmarklet.
			6989	; http://news.domain.com/submitlink?u=http://foo.com&t=Foo
			6990	; Added a confirm step to avoid xss hacks.
			6991
			6992	(newsop submitlink (u t)
			6993	(if user
			6994	(submit-page user u t)
			6995	(submit-login-warning u t)))
			6996
			6997	(= title-limit* 80
			6998	retry* "Please try again."
			6999	toolong* "Please make title < @title-limit* characters."
			7000	bothblank* "The url and text fields can't both be blank. Please
			7001	either supply a url, or if you're asking a question,
			7002	put it in the text field."
			7003	toofast* "You're submitting too fast. Please slow down. Thanks."
			7004	spammage* "Stop spamming us. You're wasting your time.")
			7005
			7006	; Only for annoyingly high-volume spammers. For ordinary spammers it's
			7007	; enough to ban their sites and ip addresses.
			7008
			7009	(disktable big-spamsites* (+ newsdir* "big-spamsites"))
			7010
			7011	(def process-story (user url title showtext text ip)
			7012	(aif (and (~blank url) (live-story-w/url url))
			7013	(do (vote-for user it)
			7014	(item-url it!id))
			7015	(if (no user)
			7016	(flink [submit-login-warning url title showtext text])
			7017	(no (and (or (blank url) (valid-url url))
			7018	(~blank title)))
			7019	(flink [submit-page user url title showtext text retry*])
			7020	(len> title title-limit*)
			7021	(flink [submit-page user url title showtext text toolong*])
			7022	(and (blank url) (blank text))
			7023	(flink [submit-page user url title showtext text bothblank*])
			7024	(let site (sitename url)
			7025	(or (big-spamsites* site) (recent-spam site)))
			7026	(flink [msgpage user spammage*])
			7027	(oversubmitting user ip 'story url)
			7028	(flink [msgpage user toofast*])
			7029	(let s (create-story url (process-title title) text user ip)
			7030	(story-ban-test user s ip url)
			7031	(when (ignored user) (kill s 'ignored))
			7032	(submit-item user s)
			7033	(maybe-ban-ip s)
			7034	"newest"))))
			7035
			7036	(def submit-item (user i)
			7037	(push i!id (uvar user submitted))
			7038	(save-prof user)
			7039	(vote-for user i))
			7040
			7041	(def recent-spam (site)
			7042	(and (caris (banned-sites* site) 'ignore)
			7043	(recent-items [is (sitename _!url) site] 720)))
			7044
			7045	(def recent-items (test minutes)
			7046	(let cutoff (- (seconds) (* 60 minutes))
			7047	(latest-items test [< _!time cutoff])))
			7048
			7049	; Turn this on when spam becomes a problem.
			7050
			7051	(= enforce-oversubmit* nil)
			7052
			7053	; New user can't submit more than 2 stories in a 2 hour period.
			7054	; Give overeager users the key toofast to make limit permanent.
			7055
			7056	(def oversubmitting (user ip kind (o url))
			7057	(and enforce-oversubmit*
			7058	(or (check-key user 'toofast)
			7059	(ignored user)
			7060	(< (user-age user) new-age-threshold*)
			7061	(< (karma user) new-karma-threshold*))
			7062	(len> (recent-items [or (author user _) (is _!ip ip)] 180)
			7063	(if (is kind 'story)
			7064	(if (bad-user user) 0 1)
			7065	(if (bad-user user) 1 10)))))
			7066
			7067	; Note that by deliberate tricks, someone could submit a story with a
			7068	; blank title.
			7069
			7070	(diskvar scrubrules* (+ newsdir* "scrubrules"))
			7071
			7072	(def process-title (s)
			7073	(let s2 (multisubst scrubrules* s)
			7074	(zap upcase (s2 0))
			7075	s2))
			7076
			7077	(def live-story-w/url (url)
			7078	(aand (url->story* (canonical-url url)) (check (item it) live)))
			7079
			7080	(def parse-site (url)
			7081	(rev (tokens (cadr (tokens url [in _ #\/ #\?])) #\.)))
			7082
			7083	(defmemo sitename (url)
			7084	(and (valid-url url)
			7085	(let toks (parse-site (rem #\space url))
			7086	(if (isa (saferead (car toks)) 'int)
			7087	(tostring (prall toks "" "."))
			7088	(let (t1 t2 t3 . rest) toks
			7089	(if (and (~in t3 nil "www")
			7090	(or (mem t1 multi-tld-countries*)
			7091	(mem t2 long-domains*)))
			7092	(+ t3 "." t2 "." t1)
			7093	(and t2 (+ t2 "." t1))))))))
			7094
			7095	(= multi-tld-countries* '("uk" "jp" "au" "in" "ph" "tr" "za" "my" "nz" "br"
			7096	"mx" "th" "sg" "id" "pk" "eg" "il" "at" "pl"))
			7097
			7098	(= long-domains* '("blogspot" "wordpress" "livejournal" "blogs" "typepad"
			7099	"weebly" "posterous" "blog-city" "supersized" "dreamhosters"
			7100	; "sampasite" "multiply" "wetpaint" ; all spam, just ban
			7101	"eurekster" "blogsome" "edogo" "blog" "com"))
			7102
			7103	(def create-story (url title text user ip)
			7104	(newslog ip user 'create url (list title))
			7105	(let s (inst 'item 'type 'story 'id (new-item-id)
			7106	'url url 'title title 'text text 'by user 'ip ip)
			7107	(save-item s)
			7108	(= (items* s!id) s)
			7109	(unless (blank url) (register-url s url))
			7110	(push s stories*)
			7111	s))
			7112
			7113
			7114	; Bans
			7115
			7116	(def ignore (user subject cause)
			7117	(set (ignored subject))
			7118	(save-prof subject)
			7119	(log-ignore user subject cause))
			7120
			7121	(diskvar ignore-log* (+ newsdir* "ignore-log"))
			7122
			7123	(def log-ignore (user subject cause)
			7124	(todisk ignore-log* (cons (list subject user cause) ignore-log*)))
			7125
			7126	; Kill means stuff with this substring gets killed. Ignore is stronger,
			7127	; means that user will be auto-ignored. Eventually this info should
			7128	; be stored on disk and not in the source code.
			7129
			7130	(disktable banned-ips* (+ newsdir* "banned-ips")) ; was ips
			7131	(disktable banned-sites* (+ newsdir* "banned-sites")) ; was sites
			7132
			7133	(diskvar comment-kill* (+ newsdir* "comment-kill"))
			7134	(diskvar comment-ignore* (+ newsdir* "comment-ignore"))
			7135
			7136	(= comment-kill* nil ip-ban-threshold* 3)
			7137
			7138	(def set-ip-ban (user ip yesno (o info))
			7139	(= (banned-ips* ip) (and yesno (list user (seconds) info)))
			7140	(todisk banned-ips*))
			7141
			7142	(def set-site-ban (user site ban (o info))
			7143	(= (banned-sites* site) (and ban (list ban user (seconds) info)))
			7144	(todisk banned-sites*))
			7145
			7146	; Kill submissions from banned ips, but don't auto-ignore users from
			7147	; them, because eventually ips will become legit again.
			7148
			7149	; Note that ban tests are only applied when a link or comment is
			7150	; submitted, not each time it's edited. This will do for now.
			7151
			7152	(def story-ban-test (user i ip url)
			7153	(site-ban-test user i url)
			7154	(ip-ban-test i ip)
			7155	(hook 'story-ban-test user i ip url))
			7156
			7157	(def site-ban-test (user i url)
			7158	(whenlet ban (banned-sites* (sitename url))
			7159	(if (caris ban 'ignore) (ignore nil user 'site-ban))
			7160	(kill i 'site-ban)))
			7161
			7162	(def ip-ban-test (i ip)
			7163	(if (banned-ips* ip) (kill i 'banned-ip)))
			7164
			7165	(def comment-ban-test (user i ip string kill-list ignore-list)
			7166	(when (some [posmatch _ string] ignore-list)
			7167	(ignore nil user 'comment-ban))
			7168	(when (or (banned-ips* ip) (some [posmatch _ string] kill-list))
			7169	(kill i 'comment-ban)))
			7170
			7171	; An IP is banned when multiple ignored users have submitted over
			7172	; ban-threshold* (currently loaded) dead stories from it.
			7173
			7174	; Can consider comments too if that later starts to be a problem,
			7175	; but the threshold may start to be higher because then you'd be
			7176	; dealing with trolls rather than spammers.
			7177
			7178	(def maybe-ban-ip (s)
			7179	(when (and s!dead (ignored s!by))
			7180	(let bads (loaded-items [and _!dead (astory _) (is _!ip s!ip)])
			7181	(when (and (len> bads ip-ban-threshold*)
			7182	(some [and (ignored _!by) (isnt _!by s!by)] bads))
			7183	(set-ip-ban nil s!ip t)))))
			7184
			7185	(def killallby (user)
			7186	(map [kill _ 'all] (submissions user)))
			7187
			7188	; Only called from repl.
			7189
			7190	(def kill-whole-thread (c)
			7191	(kill c 'thread)
			7192	(map kill-whole-thread:item c!kids))
			7193
			7194
			7195	; Polls
			7196
			7197	; a way to add a karma threshold for voting in a poll
			7198	; or better still an arbitrary test fn, or at least pair of name/threshold.
			7199	; option to sort the elements of a poll when displaying
			7200	; exclusive field? (means only allow one vote per poll)
			7201
			7202	(= poll-threshold* 20)
			7203
			7204	(newsop newpoll ()
			7205	(if (and user (> (karma user) poll-threshold*))
			7206	(newpoll-page user)
			7207	(pr "Sorry, you need @poll-threshold* karma to create a poll.")))
			7208
			7209	(def newpoll-page (user (o title "Poll: ") (o text "") (o opts "") (o msg))
			7210	(minipage "New Poll"
			7211	(pagemessage msg)
			7212	(urform user req
			7213	(process-poll (get-user req)
			7214	(striptags (arg req "t"))
			7215	(md-from-form (arg req "x") t)
			7216	(striptags (arg req "o"))
			7217	req!ip)
			7218	(tab
			7219	(row "title" (input "t" title 50))
			7220	(row "text" (textarea "x" 4 50 (only.pr text)))
			7221	(row "" "Use blank lines to separate choices:")
			7222	(row "choices" (textarea "o" 7 50 (only.pr opts)))
			7223	(row "" (submit))))))
			7224
			7225	(= fewopts* "A poll must have at least two options.")
			7226
			7227	(def process-poll (user title text opts ip)
			7228	(if (or (blank title) (blank opts))
			7229	(flink [newpoll-page user title text opts retry*])
			7230	(len> title title-limit*)
			7231	(flink [newpoll-page user title text opts toolong*])
			7232	(len< (paras opts) 2)
			7233	(flink [newpoll-page user title text opts fewopts*])
			7234	(atlet p (create-poll (multisubst scrubrules* title) text opts user ip)
			7235	(ip-ban-test p ip)
			7236	(when (ignored user) (kill p 'ignored))
			7237	(submit-item user p)
			7238	(maybe-ban-ip p)
			7239	"newest")))
			7240
			7241	(def create-poll (title text opts user ip)
			7242	(newslog ip user 'create-poll title)
			7243	(let p (inst 'item 'type 'poll 'id (new-item-id)
			7244	'title title 'text text 'by user 'ip ip)
			7245	(= p!parts (map get!id (map [create-pollopt p nil nil _ user ip]
			7246	(paras opts))))
			7247	(save-item p)
			7248	(= (items* p!id) p)
			7249	(push p stories*)
			7250	p))
			7251
			7252	(def create-pollopt (p url title text user ip)
			7253	(let o (inst 'item 'type 'pollopt 'id (new-item-id)
			7254	'url url 'title title 'text text 'parent p!id
			7255	'by user 'ip ip)
			7256	(save-item o)
			7257	(= (items* o!id) o)
			7258	o))
			7259
			7260	(def add-pollopt-page (p user)
			7261	(minipage "Add Poll Choice"
			7262	(urform user req
			7263	(do (add-pollopt user p (striptags (arg req "x")) req!ip)
			7264	(item-url p!id))
			7265	(tab
			7266	(row "text" (textarea "x" 4 50))
			7267	(row "" (submit))))))
			7268
			7269	(def add-pollopt (user p text ip)
			7270	(unless (blank text)
			7271	(atlet o (create-pollopt p nil nil text user ip)
			7272	(++ p!parts (list o!id))
			7273	(save-item p))))
			7274
			7275	(def display-pollopts (p user whence)
			7276	(each o (visible user (map item p!parts))
			7277	(display-pollopt nil o user whence)
			7278	(spacerow 7)))
			7279
			7280	(def display-pollopt (n o user whence)
			7281	(tr (display-item-number n)
			7282	(tag (td valign 'top)
			7283	(votelinks o user whence))
			7284	(tag (td class 'comment)
			7285	(tag (div style "margin-top:1px;margin-bottom:0px")
			7286	(if (~cansee user o) (pr (pseudo-text o))
			7287	(~live o) (spanclass dead
			7288	(pr (if (~blank o!title) o!title o!text)))
			7289	(if (and (~blank o!title) (~blank o!url))
			7290	(link o!title o!url)
			7291	(fontcolor black (pr o!text)))))))
			7292	(tr (if n (td))
			7293	(td)
			7294	(tag (td class 'default)
			7295	(spanclass comhead
			7296	(itemscore o)
			7297	(editlink o user)
			7298	(killlink o user whence)
			7299	(deletelink o user whence)
			7300	(deadmark o user)))))
			7301
			7302
			7303	; Individual Item Page (= Comments Page of Stories)
			7304
			7305	(defmemo item-url (id) (+ "item?id=" id))
			7306
			7307	(newsop item (id)
			7308	(let s (safe-item id)
			7309	(if (news-type s)
			7310	(do (if s!deleted (note-baditem user ip))
			7311	(item-page user s))
			7312	(do (note-baditem user ip)
			7313	(pr "No such item.")))))
			7314
			7315	(= baditemreqs* (table) baditem-threshold* 1/100)
			7316
			7317	; Something looking at a lot of deleted items is probably the bad sort
			7318	; of crawler. Throttle it for this server invocation.
			7319
			7320	(def note-baditem (user ip)
			7321	(unless (admin user)
			7322	(++ (baditemreqs* ip 0))
			7323	(with (r (requests/ip* ip) b (baditemreqs* ip))
			7324	(when (and (> r 500) (> (/ b r) baditem-threshold*))
			7325	(set (throttle-ips* ip))))))
			7326
			7327	; redefined later
			7328
			7329	(def news-type (i) (and i (in i!type 'story 'comment 'poll 'pollopt)))
			7330
			7331	(def item-page (user i)
			7332	(with (title (and (cansee user i)
			7333	(or i!title (aand i!text (ellipsize (striptags it)))))
			7334	here (item-url i!id))
			7335	(longpage user (msec) nil nil title here
			7336	(tab (display-item nil i user here)
			7337	(display-item-text i user)
			7338	(when (apoll i)
			7339	(spacerow 10)
			7340	(tr (td)
			7341	(td (tab (display-pollopts i user here)))))
			7342	(when (and (cansee user i) (comments-active i))
			7343	(spacerow 10)
			7344	(row "" (comment-form i user here))))
			7345	(br2)
			7346	(when (and i!kids (commentable i))
			7347	(tab (display-subcomments i user here))
			7348	(br2)))))
			7349
			7350	(def commentable (i) (in i!type 'story 'comment 'poll))
			7351
			7352	; By default the ability to comment on an item is turned off after
			7353	; 45 days, but this can be overriden with commentable key.
			7354
			7355	(= commentable-threshold* (* 60 24 45))
			7356
			7357	(def comments-active (i)
			7358	(and (live&commentable i)
			7359	(live (superparent i))
			7360	(or (< (item-age i) commentable-threshold*)
			7361	(mem 'commentable i!keys))))
			7362
			7363
			7364	(= displayfn* (table))
			7365
			7366	(= (displayfn* 'story) (fn (n i user here inlist)
			7367	(display-story n i user here)))
			7368
			7369	(= (displayfn* 'comment) (fn (n i user here inlist)
			7370	(display-comment n i user here nil 0 nil inlist)))
			7371
			7372	(= (displayfn* 'poll) (displayfn* 'story))
			7373
			7374	(= (displayfn* 'pollopt) (fn (n i user here inlist)
			7375	(display-pollopt n i user here)))
			7376
			7377	(def display-item (n i user here (o inlist))
			7378	((displayfn* (i 'type)) n i user here inlist))
			7379
			7380	(def superparent (i)
			7381	(aif i!parent (superparent:item it) i))
			7382
			7383	(def display-item-text (s user)
			7384	(when (and (cansee user s)
			7385	(in s!type 'story 'poll)
			7386	(blank s!url)
			7387	(~blank s!text))
			7388	(spacerow 2)
			7389	(row "" s!text)))
			7390
			7391
			7392	; Edit Item
			7393
			7394	(def edit-url (i) (+ "edit?id=" i!id))
			7395
			7396	(newsop edit (id)
			7397	(let i (safe-item id)
			7398	(if (and i
			7399	(cansee user i)
			7400	(editable-type i)
			7401	(or (news-type i) (admin user) (author user i)))
			7402	(edit-page user i)
			7403	(pr "No such item."))))
			7404
			7405	(def editable-type (i) (fieldfn* i!type))
			7406
			7407	(= fieldfn* (table))
			7408
			7409	(= (fieldfn* 'story)
			7410	(fn (user s)
			7411	(with (a (admin user) e (editor user) x (canedit user s))
			7412	`((string1 title ,s!title t ,x)
			7413	(url url ,s!url t ,e)
			7414	(mdtext2 text ,s!text t ,x)
			7415	,@(standard-item-fields s a e x)))))
			7416
			7417	(= (fieldfn* 'comment)
			7418	(fn (user c)
			7419	(with (a (admin user) e (editor user) x (canedit user c))
			7420	`((mdtext text ,c!text t ,x)
			7421	,@(standard-item-fields c a e x)))))
			7422
			7423	(= (fieldfn* 'poll)
			7424	(fn (user p)
			7425	(with (a (admin user) e (editor user) x (canedit user p))
			7426	`((string1 title ,p!title t ,x)
			7427	(mdtext2 text ,p!text t ,x)
			7428	,@(standard-item-fields p a e x)))))
			7429
			7430	(= (fieldfn* 'pollopt)
			7431	(fn (user p)
			7432	(with (a (admin user) e (editor user) x (canedit user p))
			7433	`((string title ,p!title t ,x)
			7434	(url url ,p!url t ,x)
			7435	(mdtext2 text ,p!text t ,x)
			7436	,@(standard-item-fields p a e x)))))
			7437
			7438	(def standard-item-fields (i a e x)
			7439	`((int votes ,(len i!votes) ,a nil)
			7440	(int score ,i!score t ,a)
			7441	(int sockvotes ,i!sockvotes ,a ,a)
			7442	(yesno dead ,i!dead ,e ,e)
			7443	(yesno deleted ,i!deleted ,a ,a)
			7444	(sexpr flags ,i!flags ,a nil)
			7445	(sexpr keys ,i!keys ,a ,a)
			7446	(string ip ,i!ip ,e nil)))
			7447
			7448	; Should check valid-url etc here too. In fact make a fn that
			7449	; does everything that has to happen after submitting a story,
			7450	; and call it both there and here.
			7451
			7452	(def edit-page (user i)
			7453	(let here (edit-url i)
			7454	(shortpage user nil nil "Edit" here
			7455	(tab (display-item nil i user here)
			7456	(display-item-text i user))
			7457	(br2)
			7458	(vars-form user
			7459	((fieldfn* i!type) user i)
			7460	(fn (name val)
			7461	(unless (ignore-edit user i name val)
			7462	(when (and (is name 'dead) val (no i!dead))
			7463	(log-kill i user))
			7464	(= (i name) val)))
			7465	(fn () (if (admin user) (pushnew 'locked i!keys))
			7466	(save-item i)
			7467	(metastory&adjust-rank i)
			7468	(wipe (comment-cache* i!id))
			7469	(edit-page user i)))
			7470	(hook 'edit user i))))
			7471
			7472	(def ignore-edit (user i name val)
			7473	(case name title (len> val title-limit*)
			7474	dead (and (mem 'nokill i!keys) (~admin user))))
			7475
			7476
			7477	; Comment Submission
			7478
			7479	(def comment-login-warning (parent whence (o text))
			7480	(login-page 'both "You have to be logged in to comment."
			7481	(fn (u ip)
			7482	(ensure-news-user u)
			7483	(newslog ip u 'comment-login)
			7484	(addcomment-page parent u whence text))))
			7485
			7486	(def addcomment-page (parent user whence (o text) (o msg))
			7487	(minipage "Add Comment"
			7488	(pagemessage msg)
			7489	(tab
			7490	(let here (flink [addcomment-page parent (get-user _) whence text msg])
			7491	(display-item nil parent user here))
			7492	(spacerow 10)
			7493	(row "" (comment-form parent user whence text)))))
			7494
			7495	(= noob-comment-msg* nil)
			7496
			7497	; Comment forms last for 30 min (- cache time)
			7498
			7499	(def comment-form (parent user whence (o text))
			7500	(tarform 1800
			7501	(fn (req)
			7502	(when-umatch/r user req
			7503	(process-comment user parent (arg req "text") req!ip whence)))
			7504	(textarea "text" 6 60
			7505	(aif text (prn (unmarkdown it))))
			7506	(when (and noob-comment-msg* (noob user))
			7507	(br2)
			7508	(spanclass subtext (pr noob-comment-msg*)))
			7509	(br2)
			7510	(submit (if (acomment parent) "reply" "add comment"))))
			7511
			7512	(= comment-threshold* -20)
			7513
			7514	; Have to remove #\returns because a form gives you back "a\r\nb"
			7515	; instead of just "a\nb". Maybe should just remove returns from
			7516	; the vals coming in from any form, e.g. in aform.
			7517
			7518	(def process-comment (user parent text ip whence)
			7519	(if (no user)
			7520	(flink [comment-login-warning parent whence text])
			7521	(empty text)
			7522	(flink [addcomment-page parent (get-user _) whence text retry*])
			7523	(oversubmitting user ip 'comment)
			7524	(flink [msgpage user toofast*])
			7525	(atlet c (create-comment parent (md-from-form text) user ip)
			7526	(comment-ban-test user c ip text comment-kill* comment-ignore*)
			7527	(if (bad-user user) (kill c 'ignored/karma))
			7528	(submit-item user c)
			7529	whence)))
			7530
			7531	(def bad-user (u)
			7532	(or (ignored u) (< (karma u) comment-threshold*)))
			7533
			7534	(def create-comment (parent text user ip)
			7535	(newslog ip user 'comment (parent 'id))
			7536	(let c (inst 'item 'type 'comment 'id (new-item-id)
			7537	'text text 'parent parent!id 'by user 'ip ip)
			7538	(save-item c)
			7539	(= (items* c!id) c)
			7540	(push c!id parent!kids)
			7541	(save-item parent)
			7542	(push c comments*)
			7543	c))
			7544
			7545
			7546	; Comment Display
			7547
			7548	(def display-comment-tree (c user whence (o indent 0) (o initialpar))
			7549	(when (cansee-descendant user c)
			7550	(display-1comment c user whence indent initialpar)
			7551	(display-subcomments c user whence (+ indent 1))))
			7552
			7553	(def display-1comment (c user whence indent showpar)
			7554	(row (tab (display-comment nil c user whence t indent showpar showpar))))
			7555
			7556	(def display-subcomments (c user whence (o indent 0))
			7557	(each k (sort (compare > frontpage-rank:item) c!kids)
			7558	(display-comment-tree (item k) user whence indent)))
			7559
			7560	(def display-comment (n c user whence (o astree) (o indent 0)
			7561	(o showpar) (o showon))
			7562	(tr (display-item-number n)
			7563	(when astree (td (hspace (* indent 40))))
			7564	(tag (td valign 'top) (votelinks c user whence t))
			7565	(display-comment-body c user whence astree indent showpar showon)))
			7566
			7567	; Comment caching doesn't make generation of comments significantly
			7568	; faster, but may speed up everything else by generating less garbage.
			7569
			7570	; It might solve the same problem more generally to make html code
			7571	; more efficient.
			7572
			7573	(= comment-cache* (table) comment-cache-timeout* (table) cc-window* 10000)
			7574
			7575	(= comments-printed* 0 cc-hits* 0)
			7576
			7577	(= comment-caching* t)
			7578
			7579	; Cache comments generated for nil user that are over an hour old.
			7580	; Only try to cache most recent 10k items. But this window moves,
			7581	; so if server is running a long time could have more than that in
			7582	; cache. Probably should actively gc expired cache entries.
			7583
			7584	(def display-comment-body (c user whence astree indent showpar showon)
			7585	(++ comments-printed*)
			7586	(if (and comment-caching*
			7587	astree (no showpar) (no showon)
			7588	(live c)
			7589	(nor (admin user) (editor user) (author user c))
			7590	(< (- maxid* c!id) cc-window*)
			7591	(> (- (seconds) c!time) 60)) ; was 3600
			7592	(pr (cached-comment-body c user whence indent))
			7593	(gen-comment-body c user whence astree indent showpar showon)))
			7594
			7595	(def cached-comment-body (c user whence indent)
			7596	(or (and (> (or (comment-cache-timeout* c!id) 0) (seconds))
			7597	(awhen (comment-cache* c!id)
			7598	(++ cc-hits*)
			7599	it))
			7600	(= (comment-cache-timeout* c!id)
			7601	(cc-timeout c!time)
			7602	(comment-cache* c!id)
			7603	(tostring (gen-comment-body c user whence t indent nil nil)))))
			7604
			7605	; Cache for the remainder of the current minute, hour, or day.
			7606
			7607	(def cc-timeout (t0)
			7608	(let age (- (seconds) t0)
			7609	(+ t0 (if (< age 3600)
			7610	(* (+ (trunc (/ age 60)) 1) 60)
			7611	(< age 86400)
			7612	(* (+ (trunc (/ age 3600)) 1) 3600)
			7613	(* (+ (trunc (/ age 86400)) 1) 86400)))))
			7614
			7615	(def gen-comment-body (c user whence astree indent showpar showon)
			7616	(tag (td class 'default)
			7617	(let parent (and (or (no astree) showpar) (c 'parent))
			7618	(tag (div style "margin-top:2px; margin-bottom:-10px; ")
			7619	(spanclass comhead
			7620	(itemline c user)
			7621	(permalink c user)
			7622	(when parent
			7623	(when (cansee user c) (pr bar*))
			7624	(link "parent" (item-url ((item parent) 'id))))
			7625	(editlink c user)
			7626	(killlink c user whence)
			7627	(blastlink c user whence)
			7628	(deletelink c user whence)
			7629	; a hack to check whence but otherwise need an arg just for this
			7630	(unless (or astree (is whence "newcomments"))
			7631	(flaglink c user whence))
			7632	(deadmark c user)
			7633	(when showon
			7634	(pr " \| on: ")
			7635	(let s (superparent c)
			7636	(link (ellipsize s!title 50) (item-url s!id))))))
			7637	(when (or parent (cansee user c))
			7638	(br))
			7639	(spanclass comment
			7640	(if (~cansee user c) (pr (pseudo-text c))
			7641	(nor (live c) (author user c)) (spanclass dead (pr c!text))
			7642	(fontcolor (comment-color c)
			7643	(pr c!text))))
			7644	(when (and astree (cansee user c) (live c))
			7645	(para)
			7646	(tag (font size 1)
			7647	(if (and (~mem 'neutered c!keys)
			7648	(replyable c indent)
			7649	(comments-active c))
			7650	(underline (replylink c whence))
			7651	(fontcolor sand (pr "-----"))))))))
			7652
			7653	; For really deeply nested comments, caching could add another reply
			7654	; delay, but that's ok.
			7655
			7656	; People could beat this by going to the link url or manually entering
			7657	; the reply url, but deal with that if they do.
			7658
			7659	(= reply-decay* 1.8) ; delays: (0 0 1 3 7 12 18 25 33 42 52 63)
			7660
			7661	(def replyable (c indent)
			7662	(or (< indent 2)
			7663	(> (item-age c) (expt (- indent 1) reply-decay*))))
			7664
			7665	(def replylink (i whence (o title 'reply))
			7666	(link title (+ "reply?id=" i!id "&whence=" (urlencode whence))))
			7667
			7668	(newsop reply (id whence)
			7669	(with (i (safe-item id)
			7670	whence (or (only.urldecode whence) "news"))
			7671	(if (only.comments-active i)
			7672	(if user
			7673	(addcomment-page i user whence)
			7674	(login-page 'both "You have to be logged in to comment."
			7675	(fn (u ip)
			7676	(ensure-news-user u)
			7677	(newslog ip u 'comment-login)
			7678	(addcomment-page i u whence))))
			7679	(pr "No such item."))))
			7680
			7681	(def comment-color (c)
			7682	(if (> c!score 0) black (grayrange c!score)))
			7683
			7684	(defmemo grayrange (s)
			7685	(gray (min 230 (round (expt (* (+ (abs s) 2) 900) .6)))))
			7686
			7687
			7688	; Threads
			7689
			7690	(def threads-url (user) (+ "threads?id=" user))
			7691
			7692	(newsop threads (id)
			7693	(if id
			7694	(threads-page user id)
			7695	(pr "No user specified.")))
			7696
			7697	(def threads-page (user subject)
			7698	(if (profile subject)
			7699	(withs (title (+ subject "'s comments")
			7700	label (if (is user subject) "threads" title)
			7701	here (threads-url subject))
			7702	(longpage user (msec) nil label title here
			7703	(awhen (keep [and (cansee user _) (~subcomment _)]
			7704	(comments subject maxend*))
			7705	(display-threads user it label title here))))
			7706	(prn "No such user.")))
			7707
			7708	(def display-threads (user comments label title whence
			7709	(o start 0) (o end threads-perpage*))
			7710	(tab
			7711	(each c (cut comments start end)
			7712	(display-comment-tree c user whence 0 t))
			7713	(when end
			7714	(let newend (+ end threads-perpage*)
			7715	(when (and (<= newend maxend*) (< end (len comments)))
			7716	(spacerow 10)
			7717	(row (tab (tr (td (hspace 0))
			7718	(td (hspace votewid*))
			7719	(tag (td class 'title)
			7720	(morelink display-threads
			7721	comments label title end newend))))))))))
			7722
			7723	(def submissions (user (o limit))
			7724	(map item (firstn limit (uvar user submitted))))
			7725
			7726	(def comments (user (o limit))
			7727	(map item (retrieve limit acomment:item (uvar user submitted))))
			7728
			7729	(def subcomment (c)
			7730	(some [and (acomment _) (is _!by c!by) (no _!deleted)]
			7731	(ancestors c)))
			7732
			7733	(def ancestors (i)
			7734	(accum a (trav i!parent a:item self:!parent:item)))
			7735
			7736
			7737	; Submitted
			7738
			7739	(def submitted-url (user) (+ "submitted?id=" user))
			7740
			7741	(newsop submitted (id)
			7742	(if id
			7743	(submitted-page user id)
			7744	(pr "No user specified.")))
			7745
			7746	(def submitted-page (user subject)
			7747	(if (profile subject)
			7748	(with (label (+ subject "'s submissions")
			7749	here (submitted-url subject))
			7750	(longpage user (msec) nil label label here
			7751	(if (or (no (ignored subject))
			7752	(is user subject)
			7753	(seesdead user))
			7754	(aif (keep [and (metastory _) (cansee user _)]
			7755	(submissions subject))
			7756	(display-items user it label label here 0 perpage* t)))))
			7757	(pr "No such user.")))
			7758
			7759
			7760	; RSS
			7761
			7762	(newsop rss () (rsspage nil))
			7763
			7764	(newscache rsspage user 90
			7765	(rss-stories (retrieve perpage* live ranked-stories*)))
			7766
			7767	(def rss-stories (stories)
			7768	(tag (rss version "2.0")
			7769	(tag channel
			7770	(tag title (pr this-site*))
			7771	(tag link (pr site-url*))
			7772	(tag description (pr site-desc*))
			7773	(each s stories
			7774	(tag item
			7775	(let comurl (+ site-url* (item-url s!id))
			7776	(tag title (pr (eschtml s!title)))
			7777	(tag link (pr (if (blank s!url) comurl (eschtml s!url))))
			7778	(tag comments (pr comurl))
			7779	(tag description
			7780	(cdata (link "Comments" comurl)))))))))
			7781
			7782
			7783	; User Stats
			7784
			7785	(newsop leaders () (leaderspage user))
			7786
			7787	(= nleaders* 20)
			7788
			7789	(newscache leaderspage user 1000
			7790	(longpage user (msec) nil "leaders" "Leaders" "leaders"
			7791	(sptab
			7792	(let i 0
			7793	(each u (firstn nleaders* (leading-users))
			7794	(tr (tdr:pr (++ i) ".")
			7795	(td (userlink user u nil))
			7796	(tdr:pr (karma u))
			7797	(when (admin user)
			7798	(tdr:prt (only.num (uvar u avg) 2 t t))))
			7799	(if (is i 10) (spacerow 30)))))))
			7800
			7801	(= leader-threshold* 1) ; redefined later
			7802
			7803	(def leading-users ()
			7804	(sort (compare > [karma _])
			7805	(users [and (> (karma _) leader-threshold*) (~admin _)])))
			7806
			7807	(adop editors ()
			7808	(tab (each u (users [is (uvar _ auth) 1])
			7809	(row (userlink user u)))))
			7810
			7811
			7812	(= update-avg-threshold* 0) ; redefined later
			7813
			7814	(defbg update-avg 45
			7815	(unless (or (empty profs) (no stories))
			7816	(update-avg (rand-user [and (only.> (car (uvar _ submitted))
			7817	(- maxid* initload*))
			7818	(len> (uvar _ submitted)
			7819	update-avg-threshold*)]))))
			7820
			7821	(def update-avg (user)
			7822	(= (uvar user avg) (comment-score user))
			7823	(save-prof user))
			7824
			7825	(def rand-user ((o test idfn))
			7826	(evtil (rand-key profs*) test))
			7827
			7828	; Ignore the most recent 5 comments since they may still be gaining votes.
			7829	; Also ignore the highest-scoring comment, since possibly a fluff outlier.
			7830
			7831	(def comment-score (user)
			7832	(aif (check (nthcdr 5 (comments user 50)) [len> _ 10])
			7833	(avg (cdr (sort > (map !score (rem !deleted it)))))
			7834	nil))
			7835
			7836
			7837	; Comment Analysis
			7838
			7839	; Instead of a separate active op, should probably display this info
			7840	; implicitly by e.g. changing color of commentlink or by showing the
			7841	; no of comments since that user last looked.
			7842
			7843	(newsop active () (active-page user))
			7844
			7845	(newscache active-page user 600
			7846	(listpage user (msec) (actives user) "active" "Active Threads"))
			7847
			7848	(def actives (user (o n maxend*) (o consider 2000))
			7849	(visible user (rank-stories n consider (memo active-rank))))
			7850
			7851	(= active-threshold* 1500)
			7852
			7853	(def active-rank (s)
			7854	(sum [max 0 (- active-threshold* (item-age _))]
			7855	(cdr (family s))))
			7856
			7857	(def family (i) (cons i (mappend family:item i!kids)))
			7858
			7859
			7860	(newsop newcomments () (newcomments-page user))
			7861
			7862	(newscache newcomments-page user 60
			7863	(listpage user (msec) (visible user (firstn maxend* comments*))
			7864	"comments" "New Comments" "newcomments" nil))
			7865
			7866
			7867	; Doc
			7868
			7869	(defop formatdoc req
			7870	(msgpage (get-user req) formatdoc* "Formatting Options"))
			7871
			7872	(= formatdoc-url* "formatdoc")
			7873
			7874	(= formatdoc*
			7875	"Blank lines separate paragraphs.
			7876	<p> Text after a blank line that is indented by two or more spaces is
			7877	reproduced verbatim. (This is intended for code.)
			7878	<p> Text surrounded by asterisks is italicized, if the character after the
			7879	first asterisk isn't whitespace.
			7880	<p> Urls become links, except in the text field of a submission.<br><br>")
			7881
			7882
			7883	; Noprocrast
			7884
			7885	(def check-procrast (user)
			7886	(or (no user)
			7887	(no (uvar user noprocrast))
			7888	(let now (seconds)
			7889	(unless (uvar user firstview)
			7890	(reset-procrast user))
			7891	(or (when (< (/ (- now (uvar user firstview)) 60)
			7892	(uvar user maxvisit))
			7893	(= (uvar user lastview) now)
			7894	(save-prof user)
			7895	t)
			7896	(when (> (/ (- now (uvar user lastview)) 60)
			7897	(uvar user minaway))
			7898	(reset-procrast user)
			7899	t)))))
			7900
			7901	(def reset-procrast (user)
			7902	(= (uvar user lastview) (= (uvar user firstview) (seconds)))
			7903	(save-prof user))
			7904
			7905	(def procrast-msg (user whence)
			7906	(let m (+ 1 (trunc (- (uvar user minaway)
			7907	(minutes-since (uvar user lastview)))))
			7908	(pr "<b>Get back to work!</b>")
			7909	(para "Sorry, you can't see this page. Based on the anti-procrastination
			7910	parameters you set in your profile, you'll be able to use the site
			7911	again in " (plural m "minute") ".")
			7912	(para "(If you got this message after submitting something, don't worry,
			7913	the submission was processed.)")
			7914	(para "To change your anti-procrastination settings, go to your profile
			7915	by clicking on your username. If <tt>noprocrast</tt> is set to
			7916	<tt>yes</tt>, you'll be limited to sessions of <tt>maxvisit</tt>
			7917	minutes, with <tt>minaway</tt> minutes between them.")
			7918	(para)
			7919	(w/rlink whence (underline (pr "retry")))
			7920	; (hspace 20)
			7921	; (w/rlink (do (reset-procrast user) whence) (underline (pr "override")))
			7922	(br2)))
			7923
			7924
			7925	; Reset PW
			7926
			7927	(defopg resetpw req (resetpw-page (get-user req)))
			7928
			7929	(def resetpw-page (user (o msg))
			7930	(minipage "Reset Password"
			7931	(if msg
			7932	(pr msg)
			7933	(blank (uvar user email))
			7934	(do (pr "Before you do this, please add your email address to your ")
			7935	(underlink "profile" (user-url user))
			7936	(pr ". Otherwise you could lose your account if you mistype
			7937	your new password.")))
			7938	(br2)
			7939	(uform user req (try-resetpw user (arg req "p"))
			7940	(single-input "New password: " 'p 20 "reset" t))))
			7941
			7942	(def try-resetpw (user newpw)
			7943	(if (len< newpw 4)
			7944	(resetpw-page user "Passwords should be a least 4 characters long.
			7945	Please choose another.")
			7946	(do (set-pw user newpw)
			7947	(newspage user))))
			7948
			7949
			7950	; Scrubrules
			7951
			7952	(defopa scrubrules req
			7953	(scrub-page (get-user req) scrubrules*))
			7954
			7955	; If have other global alists, generalize an alist edit page.
			7956	; Or better still generalize vars-form.
			7957
			7958	(def scrub-page (user rules (o msg nil))
			7959	(minipage "Scrubrules"
			7960	(when msg (pr msg) (br2))
			7961	(uform user req
			7962	(with (froms (lines (arg req "from"))
			7963	tos (lines (arg req "to")))
			7964	(if (is (len froms) (len tos))
			7965	(do (todisk scrubrules* (map list froms tos))
			7966	(scrub-page user scrubrules* "Changes saved."))
			7967	(scrub-page user rules "To and from should be same length.")))
			7968	(pr "From: ")
			7969	(tag (textarea name 'from
			7970	cols (apply max 20 (map len (map car rules)))
			7971	rows (+ (len rules) 3))
			7972	(apply pr #\newline (intersperse #\newline (map car rules))))
			7973	(pr " To: ")
			7974	(tag (textarea name 'to
			7975	cols (apply max 20 (map len (map cadr rules)))
			7976	rows (+ (len rules) 3))
			7977	(apply pr #\newline (intersperse #\newline (map cadr rules))))
			7978	(br2)
			7979	(submit "update"))))
			7980
			7981
			7982	; Abuse Analysis
			7983
			7984	(adop badsites ()
			7985	(sptab
			7986	(row "Dead" "Days" "Site" "O" "K" "I" "Users")
			7987	(each (site deads) (with (banned (banned-site-items)
			7988	pairs (killedsites))
			7989	(+ pairs (map [list _ (banned _)]
			7990	(rem (fn (d)
			7991	(some [caris _ d] pairs))
			7992	(keys banned-sites*)))))
			7993	(let ban (car (banned-sites* site))
			7994	(tr (tdr (when deads
			7995	(onlink (len deads)
			7996	(listpage user (msec) deads
			7997	nil (+ "killed at " site) "badsites"))))
			7998	(tdr (when deads (pr (round (days-since ((car deads) 'time))))))
			7999	(td site)
			8000	(td (w/rlink (do (set-site-ban user site nil) "badsites")
			8001	(fontcolor (if ban gray.220 black) (pr "x"))))
			8002	(td (w/rlink (do (set-site-ban user site 'kill) "badsites")
			8003	(fontcolor (case ban kill darkred gray.220) (pr "x"))))
			8004	(td (w/rlink (do (set-site-ban user site 'ignore) "badsites")
			8005	(fontcolor (case ban ignore darkred gray.220) (pr "x"))))
			8006	(td (each u (dedup (map !by deads))
			8007	(userlink user u nil)
			8008	(pr " "))))))))
			8009
			8010	(defcache killedsites 300
			8011	(let bads (table [each-loaded-item i
			8012	(awhen (and i!dead (sitename i!url))
			8013	(push i (_ it)))])
			8014	(with (acc nil deadcount (table))
			8015	(each (site items) bads
			8016	(let n (len items)
			8017	(when (> n 2)
			8018	(= (deadcount site) n)
			8019	(insort (compare > deadcount:car)
			8020	(list site (rev items))
			8021	acc))))
			8022	acc)))
			8023
			8024	(defcache banned-site-items 300
			8025	(table [each-loaded-item i
			8026	(awhen (and i!dead (check (sitename i!url) banned-sites*))
			8027	(push i (_ it)))]))
			8028
			8029	; Would be nice to auto unban ips whose most recent submission is > n
			8030	; days old, but hard to do because of lazy loading. Would have to keep
			8031	; a table of most recent submission per ip, and only enforce bannnedness
			8032	; if < n days ago.
			8033
			8034	(adop badips ()
			8035	(withs ((bads goods) (badips)
			8036	(subs ips) (sorted-badips bads goods))
			8037	(sptab
			8038	(row "IP" "Days" "Dead" "Live" "Users")
			8039	(each ip ips
			8040	(tr (td (let banned (banned-ips* ip)
			8041	(w/rlink (do (set-ip-ban user ip (no banned))
			8042	"badips")
			8043	(fontcolor (if banned darkred) (pr ip)))))
			8044	(tdr (when (or (goods ip) (bads ip))
			8045	(pr (round (days-since
			8046	(max (aif (car (goods ip)) it!time 0)
			8047	(aif (car (bads ip)) it!time 0)))))))
			8048	(tdr (onlink (len (bads ip))
			8049	(listpage user (msec) (bads ip)
			8050	nil (+ "dead from " ip) "badips")))
			8051	(tdr (onlink (len (goods ip))
			8052	(listpage user (msec) (goods ip)
			8053	nil (+ "live from " ip) "badips")))
			8054	(td (each u (subs ip)
			8055	(userlink user u nil)
			8056	(pr " "))))))))
			8057
			8058	(defcache badips 300
			8059	(with (bads (table) goods (table))
			8060	(each-loaded-item s
			8061	(if (and s!dead (commentable s))
			8062	(push s (bads s!ip))
			8063	(push s (goods s!ip))))
			8064	(each (k v) bads (zap rev (bads k)))
			8065	(each (k v) goods (zap rev (goods k)))
			8066	(list bads goods)))
			8067
			8068	(def sorted-badips (bads goods)
			8069	(withs (ips (let ips (rem [len< (bads _) 2] (keys bads))
			8070	(+ ips (rem [mem _ ips] (keys banned-ips*))))
			8071	subs (table
			8072	[each ip ips
			8073	(= (_ ip) (dedup (map !by (+ (bads ip) (goods ip)))))]))
			8074	(list subs
			8075	(sort (compare > (memo [badness (subs _) (bads _) (goods _)]))
			8076	ips))))
			8077
			8078	(def badness (subs bads goods)
			8079	(* (/ (len bads)
			8080	(max .9 (expt (len goods) 2))
			8081	(expt (+ (days-since (aif (car bads) it!time 0))
			8082	1)
			8083	2))
			8084	(if (len> subs 1) 20 1)))
			8085
			8086
			8087	(edop flagged ()
			8088	(display-selected-items user [retrieve maxend* flagged _] "flagged"))
			8089
			8090	(def flagged (i)
			8091	(and (live i)
			8092	(~mem 'nokill i!keys)
			8093	(len> i!flags many-flags*)))
			8094
			8095
			8096	(edop killed ()
			8097	(display-selected-items user [retrieve maxend* !dead _] "killed"))
			8098
			8099	(def display-selected-items (user f whence)
			8100	(display-items user (f stories*) nil nil whence)
			8101	(vspace 35)
			8102	(color-stripe textgray)
			8103	(vspace 35)
			8104	(display-items user (f comments*) nil nil whence))
			8105
			8106
			8107	; Rather useless thus; should add more data.
			8108
			8109	(adop badguys ()
			8110	(tab (each u (sort (compare > [uvar _ created])
			8111	(users [ignored _]))
			8112	(row (userlink user u nil)))))
			8113
			8114	(adop badlogins () (logins-page bad-logins*))
			8115
			8116	(adop goodlogins () (logins-page good-logins*))
			8117
			8118	(def logins-page (source)
			8119	(sptab (each (time ip user) (firstn 100 (rev (qlist source)))
			8120	(row time ip user))))
			8121
			8122
			8123	; Stats
			8124
			8125	(adop optimes ()
			8126	(sptab
			8127	(tr (td "op") (tdr "avg") (tdr "med") (tdr "req") (tdr "total"))
			8128	(spacerow 10)
			8129	(each name (sort < newsop-names*)
			8130	(tr (td name)
			8131	(let ms (only.avg (qlist (optimes* name)))
			8132	(tdr:prt (only.round ms))
			8133	(tdr:prt (only.med (qlist (optimes* name))))
			8134	(let n (opcounts* name)
			8135	(tdr:prt n)
			8136	(tdr:prt (and n (round (/ (* n ms) 1000))))))))))
			8137
			8138	(defop topcolors req
			8139	(minipage "Custom Colors"
			8140	(tab
			8141	(each c (dedup (map downcase (trues [uvar _ topcolor] (users))))
			8142	(tr (td c) (tdcolor (hex>color c) (hspace 30)))))))
			8143
			8144
			8145