commit 3386ec0c4bbeb9785a50944f6cd11da96a36f2b4
Author: hellerve <veit@veitheller.de>
Date:   Mon May 14 00:08:25 2018 +0200

    initial

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..06c05c2
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+argos
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..02f0fab
--- /dev/null
+++ b/README.md
@@ -0,0 +1,68 @@
+# argos
+
+*Very early WIP.*
+
+[Arc](http://www.arclanguage.org) in Go.
+
+## TODOS
+
+- Destructuring assignment
+- Defining functions
+- Anonymous functions
+- Datastructures as functions
+- Characters
+- `let`
+- `with`
+- `pr`
+- `prn`
+- `if`
+- `do`
+- `when`
+- `and`
+- `no`
+- `is`
+- `in`
+- `case`
+- `for`
+- `each`
+- `while`
+- `repeat`
+- `[...]`
+- `:`
+- `~`
+- `keep`
+- `rem`
+- `all`
+- `some`
+- `pos`
+- `trues`
+- `table`
+- `listtab`
+- `obj`
+- `keys`
+- `vals`
+- `maptable`
+- `alref`
+- `string`
+- `tostring`
+- `type`
+- `coerce`
+- `pop`
+- `push`
+- `++`
+- `--`
+- `zap`
+- `sort`
+- `insort`
+- `compare`
+- `o`
+- `.`
+- `apply`
+- `len`
+- `mac`
+- `\``
+- `defop`
+- `asv`
+- `w/link`
+- `aform`
+- ...
diff --git a/ast/ast.go b/ast/ast.go
new file mode 100644
index 0000000..76dee5a
--- /dev/null
+++ b/ast/ast.go
@@ -0,0 +1,44 @@
+package ast
+
+import (
+  "fmt"
+  "strings"
+)
+
+type AST struct {
+  Tag Tag
+  Val interface{}
+}
+
+type Tag int8
+
+const (
+  Symbol Tag = iota
+  List
+  String
+  Num
+  Bool
+)
+
+func (tag Tag) String() string {
+    names := []string{
+        "Symbol",
+        "List",
+        "String",
+        "Num",
+        "Bool",
+    }
+
+    return names[tag]
+}
+
+func (ast AST) Pretty() string {
+  if ast.Tag == List {
+    var agg []string
+    for _, elem := range(ast.Val.([]AST)) {
+      agg = append(agg, elem.Pretty())
+    }
+    return "(" + strings.Join(agg, " ") + ")"
+  }
+  return fmt.Sprintf("%v", ast.Val)
+}
diff --git a/eval/eval.go b/eval/eval.go
new file mode 100644
index 0000000..b778d8f
--- /dev/null
+++ b/eval/eval.go
@@ -0,0 +1,308 @@
+package eval
+
+// TODO: a lot of code duplication that can be solved by a primitive registry
+// TODO: a lot of code duplication that can be solved by a type checking helper
+
+import (
+  "fmt"
+
+  "github.com/hellerve/argos/ast"
+)
+
+var trueVal = ast.AST{ast.Bool, true}
+var falseVal = ast.AST{ast.Bool, false}
+var nilVal = ast.AST{ast.List, []ast.AST{}}
+
+type env struct {
+  parent *env
+  values map[string]*ast.AST
+}
+
+func newEnv(parent *env) env {
+  return env{parent, make(map[string]*ast.AST)}
+}
+
+func ParentEnv() env {
+  return newEnv(nil)
+}
+
+func (e env) Lookup(elem string) (*ast.AST, error) {
+  res, ok := e.values[elem]
+
+  if !ok {
+    if e.parent == nil {
+      return nil, fmt.Errorf("Symbol not found: %s", elem)
+    }
+
+    return e.parent.Lookup(elem)
+  }
+
+  return res, nil
+}
+
+func checkArity(input []ast.AST, arity int, name string) error {
+  ilen := len(input)
+  if ilen != arity+1 {
+    return fmt.Errorf("Argument count to '%s' must be %d, was %d", name, arity, ilen)
+  }
+
+  return nil
+}
+
+func evalDef(input []ast.AST, e env) (*ast.AST, error) {
+  err := checkArity(input, 2, "=")
+
+  if err != nil {
+    return nil, err
+  }
+
+  variable := &input[1]
+
+  if variable.Tag != ast.Symbol {
+    variable, err = Eval(variable, e)
+
+    if variable.Tag != ast.Symbol {
+      return nil, fmt.Errorf("First argument to 'def' must be symbol, was %v", variable.Tag)
+    }
+  }
+
+  if err != nil {
+    return nil, err
+  }
+
+  sym := variable.Val.(string)
+
+  evald, err := Eval(&input[2], e)
+
+  if err != nil {
+    return nil, err
+  }
+
+  e.values[sym] = evald
+
+  return evald, nil
+}
+
+func arithCast(input ast.AST, e env) (float64, error) {
+  evald, err := Eval(&input, e)
+  if err != nil {
+    return 0, err
+  }
+
+  if evald.Tag != ast.Num {
+    return 0, fmt.Errorf("Cannot perform arithmetic on ", evald.Pretty())
+  }
+
+  return evald.Val.(float64), nil
+}
+
+func evalArith(input []ast.AST, e env, fn (func(float64, float64) float64)) (*ast.AST, error) {
+  ilen := len(input)
+  if ilen < 3 {
+    return nil, fmt.Errorf("Arithmetic functions take at least 2 arguments, got %d", ilen)
+  }
+
+  acc, err := arithCast(input[1], e)
+
+  if err != nil {
+    return nil, err
+  }
+
+  for _, elem := range input[2:] {
+    val, err := arithCast(elem, e)
+
+    if err != nil {
+      return nil, err
+    }
+    acc = fn(acc, val)
+  }
+
+  res := ast.AST{ast.Num, acc}
+  return &res, nil
+}
+
+func evalEq(input []ast.AST, e env) (*ast.AST, error) {
+  err := checkArity(input, 2, "iso")
+
+  if err != nil {
+    return nil, err
+  }
+
+  x, err := Eval(&input[1], e)
+
+  if err != nil {
+    return nil, err
+  }
+
+  y, err := Eval(&input[2], e)
+
+  if err != nil {
+    return nil, err
+  }
+
+  if x.Tag != y.Tag {
+    return &falseVal, nil
+  }
+
+  if x.Val == y.Val {
+    return &trueVal, nil
+  }
+  return &falseVal, nil
+}
+
+func evalCons(input []ast.AST, e env) (*ast.AST, error) {
+  err := checkArity(input, 2, "cons")
+
+  if err != nil {
+    return nil, err
+  }
+
+  lst, err := Eval(&input[2], e)
+
+  if err != nil {
+    return nil, err
+  }
+
+  if lst.Tag != ast.List {
+    return nil, fmt.Errorf("Cannot cons to non-list %s", lst.Pretty())
+  }
+
+  fst, err := Eval(&input[1], e)
+
+  if err != nil {
+    return nil, err
+  }
+
+  res := ast.AST{ast.List, append([]ast.AST{*fst}, lst.Val.([]ast.AST)...)}
+
+  return &res, nil
+}
+
+func evalCar(input []ast.AST, e env) (*ast.AST, error) {
+  err := checkArity(input, 1, "car")
+
+  if err != nil {
+    return nil, err
+  }
+
+  lst, err := Eval(&input[1], e)
+
+  if err != nil {
+    return nil, err
+  }
+
+  if lst.Tag != ast.List {
+    return nil, fmt.Errorf("Cannot car from non-list %s", lst.Pretty())
+  }
+
+  res := lst.Val.([]ast.AST)[0]
+  return &res, nil
+}
+
+func evalCdr(input []ast.AST, e env) (*ast.AST, error) {
+  err := checkArity(input, 1, "cdr")
+
+  if err != nil {
+    return nil, err
+  }
+
+  lst, err := Eval(&input[1], e)
+
+  if err != nil {
+    return nil, err
+  }
+
+  if lst.Tag != ast.List {
+    return nil, fmt.Errorf("Cannot cdr from non-list %s", lst.Pretty())
+  }
+
+  res := ast.AST{ast.List, lst.Val.([]ast.AST)[1:]}
+  return &res, nil
+}
+
+func evalNull(input []ast.AST, e env) (*ast.AST, error) {
+  err := checkArity(input, 1, "null")
+
+  if err != nil {
+    return nil, err
+  }
+
+  lst, err := Eval(&input[1], e)
+
+  if err != nil {
+    return nil, err
+  }
+
+  if lst.Tag != ast.List {
+    return nil, fmt.Errorf("Cannot call null? on non-list %s", lst.Pretty())
+  }
+
+  res := ast.AST{ast.Bool, len(lst.Val.([]ast.AST)) == 0}
+  return &res, nil
+}
+
+func evalList(input *ast.AST, e env) (*ast.AST, error) {
+  l := input.Val.([]ast.AST)
+  head := l[0]
+
+  if head.Tag != ast.Symbol {
+    err := fmt.Errorf("Calling non-symbol: %s", head.Pretty())
+
+    return nil, err
+  }
+
+  sym := head.Val.(string)
+
+  switch sym {
+    case "=":
+      return evalDef(l, e)
+    case "iso":
+      return evalEq(l, e)
+    case "quote":
+      res := l[1]
+      return &res, nil
+    case "cons":
+      return evalCons(l, e)
+    case "car":
+      return evalCar(l, e)
+    case "cdr":
+      return evalCdr(l, e)
+    case "null?":
+      return evalNull(l, e)
+    case "+":
+      return evalArith(l, e, func(x float64, y float64) float64 { return x + y })
+    case "-":
+      return evalArith(l, e, func(x float64, y float64) float64 { return x - y })
+    case "*":
+      return evalArith(l, e, func(x float64, y float64) float64 { return x * y })
+    case "/":
+      return evalArith(l, e, func(x float64, y float64) float64 { return x / y })
+    case "%":
+      return evalArith(l, e, func(x float64, y float64) float64 { return float64(int64(x) % int64(y)) })
+  }
+  return input, nil
+}
+
+func Eval(input *ast.AST, e env) (*ast.AST, error) {
+  if (input.Tag == ast.List) {
+    return evalList(input, e)
+  }
+  if (input.Tag == ast.Symbol) {
+    val := input.Val.(string)
+
+    var err error
+    var res *ast.AST
+    switch val {
+      case "true":
+        res = &trueVal
+      case "false":
+        res = &falseVal
+      case "nil":
+        res = &nilVal
+      default:
+        res, err = e.Lookup(val)
+    }
+    return res, err
+  }
+  return input, nil
+}
diff --git a/lib/README.md b/lib/README.md
new file mode 100644
index 0000000..250ae23
--- /dev/null
+++ b/lib/README.md
@@ -0,0 +1,5 @@
+# lib
+
+The Arc files from Arc3.1, obtainable [here](http://www.arclanguage.org/arc3.1.tar),
+copied verbatim. See [copyright](./copyright) for the original copyright. I do
+not own any of this, nor have I written any of it.
diff --git a/lib/app.arc b/lib/app.arc
new file mode 100644
index 0000000..292800f
--- /dev/null
+++ b/lib/app.arc
@@ -0,0 +1,671 @@
+; Application Server.  Layer inserted 2 Sep 06.
+
+; ideas: 
+; def a general notion of apps of which prompt is one, news another
+; give each user a place to store data?  A home dir?
+
+; A user is simply a string: "pg". Use /whoami to test user cookie.
+
+(= hpwfile*   "arc/hpw"
+   oidfile*   "arc/openids"
+   adminfile* "arc/admins"
+   cookfile*  "arc/cooks")
+
+(def asv ((o port 8080))
+  (load-userinfo)
+  (serve port))
+
+(def load-userinfo ()
+  (= hpasswords*   (safe-load-table hpwfile*)
+     openids*      (safe-load-table oidfile*)
+     admins*       (map string (errsafe (readfile adminfile*)))
+     cookie->user* (safe-load-table cookfile*))
+  (maptable (fn (k v) (= (user->cookie* v) k))
+            cookie->user*))
+
+; idea: a bidirectional table, so don't need two vars (and sets)
+
+(= cookie->user* (table) user->cookie* (table) logins* (table))
+
+(def get-user (req) 
+  (let u (aand (alref req!cooks "user") (cookie->user* (sym it)))
+    (when u (= (logins* u) req!ip))
+    u))
+
+(mac when-umatch (user req . body)
+  `(if (is ,user (get-user ,req))
+       (do ,@body)
+       (mismatch-message)))
+
+(def mismatch-message () 
+  (prn "Dead link: users don't match."))
+
+(mac when-umatch/r (user req . body)
+  `(if (is ,user (get-user ,req))
+       (do ,@body)
+       "mismatch"))
+
+(defop mismatch req (mismatch-message))
+
+(mac uform (user req after . body)
+  `(aform (fn (,req)
+            (when-umatch ,user ,req
+              ,after))
+     ,@body))
+
+(mac urform (user req after . body)
+  `(arform (fn (,req)
+             (when-umatch/r ,user ,req 
+               ,after))
+     ,@body))
+
+; Like onlink, but checks that user submitting the request is the
+; same it was generated for.  For extra protection could log the 
+; username and ip addr of every genlink, and check if they match.
+
+(mac ulink (user text . body)  
+  (w/uniq req
+    `(linkf ,text (,req) 
+       (when-umatch ,user ,req ,@body))))
+
+
+(defop admin req (admin-gate (get-user req)))
+
+(def admin-gate (u)
+  (if (admin u)
+      (admin-page u)
+      (login-page 'login nil
+                  (fn (u ip)  (admin-gate u)))))
+
+(def admin (u) (and u (mem u admins*)))
+
+(def user-exists (u) (and u (hpasswords* u) u))
+
+(def admin-page (user . msg)
+  (whitepage 
+    (prbold "Admin: ")
+    (hspace 20)
+    (pr user " | ")
+    (w/link (do (logout-user user)
+                (whitepage (pr "Bye " user ".")))
+      (pr "logout"))
+    (when msg (hspace 10) (map pr msg))
+    (br2)
+    (aform (fn (req)
+             (when-umatch user req
+               (with (u (arg req "u") p (arg req "p"))
+                 (if (or (no u) (no p) (is u "") (is p ""))
+                      (pr "Bad data.")
+                     (user-exists u)
+                      (admin-page user "User already exists: " u)
+                      (do (create-acct u p)
+                          (admin-page user))))))
+      (pwfields "create (server) account"))))
+
+(def cook-user (user)
+  (let id (new-user-cookie)
+    (= (cookie->user*   id) user
+       (user->cookie* user)   id)
+    (save-table cookie->user* cookfile*)
+    id))
+
+; Unique-ids are only unique per server invocation.
+
+(def new-user-cookie ()
+  (let id (unique-id)
+    (if (cookie->user* id) (new-user-cookie) id)))
+
+(def logout-user (user)
+  (wipe (logins* user))
+  (wipe (cookie->user* (user->cookie* user)) (user->cookie* user))
+  (save-table cookie->user* cookfile*))
+
+(def create-acct (user pw)
+  (set (dc-usernames* (downcase user)))
+  (set-pw user pw))
+
+(def disable-acct (user)
+  (set-pw user (rand-string 20))
+  (logout-user user))
+  
+(def set-pw (user pw)
+  (= (hpasswords* user) (and pw (shash pw)))
+  (save-table hpasswords* hpwfile*))
+
+(def hello-page (user ip)
+  (whitepage (prs "hello" user "at" ip)))
+
+(defop login req (login-page 'login))
+
+; switch is one of: register, login, both
+
+; afterward is either a function on the newly created username and
+; ip address, in which case it is called to generate the next page 
+; after a successful login, or a pair of (function url), which means 
+; call the function, then redirect to the url.
+
+; classic example of something that should just "return" a val
+; via a continuation rather than going to a new page.
+
+(def login-page (switch (o msg nil) (o afterward hello-page))
+  (whitepage
+    (pagemessage msg)
+    (when (in switch 'login 'both)
+      (login-form "Login" switch login-handler afterward)
+      (hook 'login-form afterward)
+      (br2))
+    (when (in switch 'register 'both)
+      (login-form "Create Account" switch create-handler afterward))))
+
+(def login-form (label switch handler afterward)
+  (prbold label)
+  (br2)
+  (fnform (fn (req) (handler req switch afterward))
+          (fn () (pwfields (downcase label)))
+          (acons afterward)))
+
+(def login-handler (req switch afterward)
+  (logout-user (get-user req))
+  (aif (good-login (arg req "u") (arg req "p") req!ip)
+       (login it req!ip (user->cookie* it) afterward)
+       (failed-login switch "Bad login." afterward)))
+
+(def create-handler (req switch afterward)
+  (logout-user (get-user req))
+  (with (user (arg req "u") pw (arg req "p"))
+    (aif (bad-newacct user pw)
+         (failed-login switch it afterward)
+         (do (create-acct user pw)
+             (login user req!ip (cook-user user) afterward)))))
+
+(def login (user ip cookie afterward)
+  (= (logins* user) ip)
+  (prcookie cookie)
+  (if (acons afterward)
+      (let (f url) afterward
+        (f user ip)
+        url)
+      (do (prn)
+          (afterward user ip))))
+
+(def failed-login (switch msg afterward)
+  (if (acons afterward)
+      (flink (fn ignore (login-page switch msg afterward)))
+      (do (prn)
+          (login-page switch msg afterward))))
+
+(def prcookie (cook)
+  (prn "Set-Cookie: user=" cook "; expires=Sun, 17-Jan-2038 19:14:07 GMT"))
+
+(def pwfields ((o label "login"))
+  (inputs u username 20 nil
+          p password 20 nil)
+  (br)
+  (submit label))
+
+(= good-logins* (queue) bad-logins* (queue))
+
+(def good-login (user pw ip)
+  (let record (list (seconds) ip user)
+    (if (and user pw (aand (shash pw) (is it (hpasswords* user))))
+        (do (unless (user->cookie* user) (cook-user user))
+            (enq-limit record good-logins*)
+            user)
+        (do (enq-limit record bad-logins*)
+            nil))))
+
+; Create a file in case people have quote chars in their pws.  I can't 
+; believe there's no way to just send the chars.
+
+(def shash (str)
+  (let fname (+ "/tmp/shash" (rand-string 10))
+    (w/outfile f fname (disp str f))
+    (let res (tostring (system (+ "openssl dgst -sha1 <" fname)))
+      (do1 (cut res 0 (- (len res) 1))
+           (rmfile fname)))))
+
+(= dc-usernames* (table))
+
+(def username-taken (user)
+  (when (empty dc-usernames*)
+    (each (k v) hpasswords*
+      (set (dc-usernames* (downcase k)))))
+  (dc-usernames* (downcase user)))
+
+(def bad-newacct (user pw)
+  (if (no (goodname user 2 15))
+       "Usernames can only contain letters, digits, dashes and 
+        underscores, and should be between 2 and 15 characters long.  
+        Please choose another."
+      (username-taken user)
+       "That username is taken. Please choose another."
+      (or (no pw) (< (len pw) 4))
+       "Passwords should be a least 4 characters long.  Please 
+        choose another."
+       nil))
+
+(def goodname (str (o min 1) (o max nil))
+  (and (isa str 'string)
+       (>= (len str) min)
+       (~find (fn (c) (no (or (alphadig c) (in c #\- #\_))))
+              str)
+       (isnt (str 0) #\-)
+       (or (no max) (<= (len str) max))
+       str))
+
+(defop logout req
+  (aif (get-user req)
+       (do (logout-user it)
+           (pr "Logged out."))
+       (pr "You were not logged in.")))
+
+(defop whoami req
+  (aif (get-user req)
+       (prs it 'at req!ip)
+       (do (pr "You are not logged in. ")
+           (w/link (login-page 'both) (pr "Log in"))
+           (pr "."))))
+
+
+(= formwid* 60 bigformwid* 80 numwid* 16 formatdoc-url* nil)
+
+; Eventually figure out a way to separate type name from format of 
+; input field, instead of having e.g. toks and bigtoks
+
+(def varfield (typ id val)
+  (if (in typ 'string 'string1 'url)
+       (gentag input type 'text name id value val size formwid*)
+      (in typ 'num 'int 'posint 'sym)
+       (gentag input type 'text name id value val size numwid*)
+      (in typ 'users 'toks)
+       (gentag input type 'text name id value (tostring (apply prs val))
+                     size formwid*)    
+      (is typ 'sexpr)
+       (gentag input type 'text name id 
+                     value (tostring (map [do (write _) (sp)] val))
+                     size formwid*)
+      (in typ 'syms 'text 'doc 'mdtext 'mdtext2 'lines 'bigtoks)
+       (let text (if (in typ 'syms 'bigtoks)
+                      (tostring (apply prs val))
+                     (is typ 'lines)
+                      (tostring (apply pr (intersperse #\newline val)))
+                     (in typ 'mdtext 'mdtext2)
+                      (unmarkdown val)
+                     (no val)
+                      ""
+                     val)
+         (tag (textarea cols (if (is typ 'doc) bigformwid* formwid*) 
+                        rows (needrows text formwid* 4)
+                        wrap 'virtual 
+                        style (if (is typ 'doc) "font-size:8.5pt")
+                        name id)
+           (prn) ; needed or 1 initial newline gets chopped off
+           (pr text))
+         (when (and formatdoc-url* (in typ 'mdtext 'mdtext2))
+           (pr " ")
+           (tag (font size -2)
+             (link "help" formatdoc-url* (gray 175)))))
+      (caris typ 'choice)
+       (menu id (cddr typ) val)
+      (is typ 'yesno)
+       (menu id '("yes" "no") (if val "yes" "no"))
+      (is typ 'hexcol)
+       (gentag input type 'text name id value val)
+      (is typ 'time)
+       (gentag input type 'text name id value (if val (english-time val) ""))
+      (is typ 'date)
+       (gentag input type 'text name id value (if val (english-date val) ""))
+       (err "unknown varfield type" typ)))
+
+(def text-rows (text wid (o pad 3))
+  (+ (trunc (/ (len text) (* wid .8))) pad))
+
+(def needrows (text cols (o pad 0))
+  (+ pad (max (+ 1 (count #\newline text))
+              (roundup (/ (len text) (- cols 5))))))
+
+(def varline (typ id val (o liveurls))
+  (if (in typ 'users 'syms 'toks 'bigtoks)  (apply prs val)
+      (is typ 'lines)                       (map prn val)
+      (is typ 'yesno)                       (pr (if val 'yes 'no))
+      (caris typ 'choice)                   (varline (cadr typ) nil val)
+      (is typ 'url)                         (if (and liveurls (valid-url val))
+                                                (link val val)
+                                                (pr val))
+      (text-type typ)                       (pr (or val ""))
+                                            (pr val)))
+
+(def text-type (typ) (in typ 'string 'string1 'url 'text 'mdtext 'mdtext2))
+
+; Newlines in forms come back as /r/n.  Only want the /ns. Currently
+; remove the /rs in individual cases below.  Could do it in aform or
+; even in the parsing of http requests, in the server.
+
+; Need the calls to striptags so that news users can't get html
+; into a title or comment by editing it.  If want a form that 
+; can take html, just create another typ for it.
+
+(def readvar (typ str (o fail nil))
+  (case (carif typ)
+    string  (striptags str)
+    string1 (if (blank str) fail (striptags str))
+    url     (if (blank str) "" (valid-url str) (clean-url str) fail)
+    num     (let n (saferead str) (if (number n) n fail))
+    int     (let n (saferead str)
+              (if (number n) (round n) fail))
+    posint  (let n (saferead str)
+              (if (and (number n) (> n 0)) (round n) fail))
+    text    (striptags str)
+    doc     (striptags str)
+    mdtext  (md-from-form str)
+    mdtext2 (md-from-form str t)                      ; for md with no links
+    sym     (or (sym:car:tokens str) fail)
+    syms    (map sym (tokens str))
+    sexpr   (errsafe (readall str))
+    users   (rem [no (goodname _)] (tokens str))
+    toks    (tokens str)
+    bigtoks (tokens str)
+    lines   (lines str)
+    choice  (readvar (cadr typ) str)
+    yesno   (is str "yes")
+    hexcol  (if (hex>color str) str fail)
+    time    (or (errsafe (parse-time str)) fail)
+    date    (or (errsafe (parse-date str)) fail)
+            (err "unknown readvar type" typ)))
+
+; dates should be tagged date, and just redefine <
+
+(def varcompare (typ)
+  (if (in typ 'syms 'sexpr 'users 'toks 'bigtoks 'lines 'hexcol)
+       (fn (x y) (> (len x) (len y)))
+      (is typ 'date)
+       (fn (x y)
+         (or (no y) (and x (date< x y))))
+       (fn (x y)
+         (or (empty y) (and (~empty x) (< x y))))))
+
+
+; (= fail* (uniq))
+
+(def fail* ()) ; coudn't possibly come back from a form
+  
+; Takes a list of fields of the form (type label value view modify) and 
+; a fn f and generates a form such that when submitted (f label newval) 
+; will be called for each valid value.  Finally done is called.
+
+(def vars-form (user fields f done (o button "update") (o lasts))
+  (taform lasts
+          (if (all [no (_ 4)] fields)
+              (fn (req))
+              (fn (req)
+                (when-umatch user req
+                  (each (k v) req!args
+                    (let name (sym k)
+                      (awhen (find [is (cadr _) name] fields)
+                        ; added sho to fix bug
+                        (let (typ id val sho mod) it
+                          (when (and mod v)
+                            (let newval (readvar typ v fail*)
+                              (unless (is newval fail*)
+                                (f name newval))))))))
+                  (done))))
+     (tab
+       (showvars fields))
+     (unless (all [no (_ 4)] fields)  ; no modifiable fields
+       (br)
+       (submit button))))
+                
+(def showvars (fields (o liveurls))
+  (each (typ id val view mod question) fields
+    (when view
+      (when question
+        (tr (td (prn question))))
+      (tr (unless question (tag (td valign 'top)  (pr id ":")))
+          (td (if mod 
+                  (varfield typ id val)
+                  (varline  typ id val liveurls))))
+      (prn))))
+
+; http://daringfireball.net/projects/markdown/syntax
+
+(def md-from-form (str (o nolinks))
+  (markdown (trim (rem #\return (esc-tags str)) 'end) 60 nolinks))
+
+(def markdown (s (o maxurl) (o nolinks))
+  (let ital nil
+    (tostring
+      (forlen i s
+        (iflet (newi spaces) (indented-code s i (if (is i 0) 2 0))
+               (do (pr  "<p><pre><code>")
+                 (let cb (code-block s (- newi spaces 1))
+                   (pr cb)
+                   (= i (+ (- newi spaces 1) (len cb))))
+                 (pr "</code></pre>"))
+               (iflet newi (parabreak s i (if (is i 0) 1 0))
+                      (do (unless (is i 0) (pr "<p>"))
+                          (= i (- newi 1)))
+                      (and (is (s i) #\*)
+                           (or ital 
+                               (atend i s) 
+                               (and (~whitec (s (+ i 1)))
+                                    (pos #\* s (+ i 1)))))
+                       (do (pr (if ital "</i>" "<i>"))
+                           (= ital (no ital)))
+                      (and (no nolinks)
+                           (or (litmatch "http://" s i) 
+                               (litmatch "https://" s i)))
+                       (withs (n   (urlend s i)
+                               url (clean-url (cut s i n)))
+                         (tag (a href url rel 'nofollow)
+                           (pr (if (no maxurl) url (ellipsize url maxurl))))
+                         (= i (- n 1)))
+                       (writec (s i))))))))
+
+(def indented-code (s i (o newlines 0) (o spaces 0))
+  (let c (s i)
+    (if (nonwhite c)
+         (if (and (> newlines 1) (> spaces 1))
+             (list i spaces)
+             nil)
+        (atend i s)
+         nil
+        (is c #\newline)
+         (indented-code s (+ i 1) (+ newlines 1) 0)
+         (indented-code s (+ i 1) newlines       (+ spaces 1)))))
+
+; If i is start a paragraph break, returns index of start of next para.
+
+(def parabreak (s i (o newlines 0))
+  (let c (s i)
+    (if (or (nonwhite c) (atend i s))
+        (if (> newlines 1) i nil)
+        (parabreak s (+ i 1) (+ newlines (if (is c #\newline) 1 0))))))
+
+; Returns the indices of the next paragraph break in s, if any.
+
+(def next-parabreak (s i)
+  (unless (atend i s)
+    (aif (parabreak s i) 
+         (list i it)
+         (next-parabreak s (+ i 1)))))
+
+(def paras (s (o i 0))
+  (if (atend i s)
+      nil
+      (iflet (endthis startnext) (next-parabreak s i)
+             (cons (cut s i endthis)
+                   (paras s startnext))
+             (list (trim (cut s i) 'end)))))
+
+
+; Returns the index of the first char not part of the url beginning
+; at i, or len of string if url goes all the way to the end.
+
+; Note that > immediately after a url (http://foo.com>) will cause
+; an odd result, because the > gets escaped to something beginning
+; with &, which is treated as part of the url.  Perhaps the answer
+; is just to esc-tags after markdown instead of before.
+
+; Treats a delimiter as part of a url if it is (a) an open delimiter
+; not followed by whitespace or eos, or (b) a close delimiter 
+; balancing a previous open delimiter.
+
+(def urlend (s i (o indelim))
+  (let c (s i)
+    (if (atend i s)
+         (if ((orf punc whitec opendelim) c) 
+              i 
+             (closedelim c)
+              (if indelim (+ i 1) i)
+             (+ i 1))
+        (if (or (whitec c)
+                (and (punc c) (whitec (s (+ i 1))))
+                (and ((orf whitec punc) (s (+ i 1)))
+                     (or (opendelim c)
+                         (and (closedelim c) (no indelim)))))
+            i
+            (urlend s (+ i 1) (or (opendelim c)
+                                  (and indelim (no (closedelim c)))))))))
+
+(def opendelim (c)  (in c #\< #\( #\[ #\{))
+ 
+(def closedelim (c) (in c #\> #\) #\] #\}))
+
+
+(def code-block (s i)
+  (tostring
+    (until (let left (- (len s) i 1)
+             (or (is left 0)
+                 (and (> left 2)
+                      (is (s (+ i 1)) #\newline)
+                      (nonwhite (s (+ i 2))))))
+     (writec (s (++ i))))))
+
+(def unmarkdown (s)
+  (tostring
+    (forlen i s
+      (if (litmatch "<p>" s i)
+           (do (++ i 2) 
+               (unless (is i 2) (pr "\n\n")))
+          (litmatch "<i>" s i)
+           (do (++ i 2) (pr #\*))
+          (litmatch "</i>" s i)
+           (do (++ i 3) (pr #\*))
+          (litmatch "<a href=" s i)
+           (let endurl (posmatch [in _ #\> #\space] s (+ i 9))
+             (if endurl
+                 (do (pr (cut s (+ i 9) (- endurl 1)))
+                     (= i (aif (posmatch "</a>" s endurl)
+                               (+ it 3)
+                               endurl)))
+                 (writec (s i))))
+          (litmatch "<pre><code>" s i)
+           (awhen (findsubseq "</code></pre>" s (+ i 12))
+             (pr (cut s (+ i 11) it))
+             (= i (+ it 12)))
+          (writec (s i))))))
+
+
+(def english-time (min)
+  (let n (mod min 720)
+    (string (let h (trunc (/ n 60)) (if (is h 0) "12" h))
+            ":"
+            (let m (mod n 60)
+              (if (is m 0) "00"
+                  (< m 10) (string "0" m)
+                           m))
+            (if (is min 0)   " midnight"
+                (is min 720) " noon"
+                (>= min 720) " pm"
+                             " am"))))
+
+(def parse-time (s)
+  (let (nums (o label "")) (halve s letter)
+    (with ((h (o m 0)) (map int (tokens nums ~digit))
+           cleanlabel  (downcase (rem ~alphadig label)))
+      (+ (* (if (is h 12)
+                 (if (in cleanlabel "am" "midnight")
+                     0
+                     12)
+                (is cleanlabel "am")
+                 h
+                 (+ h 12))
+            60)
+          m))))
+
+
+(= months* '("January" "February" "March" "April" "May" "June" "July"
+             "August" "September" "October" "November" "December"))
+
+(def english-date ((y m d))
+  (string d " " (months* (- m 1)) " " y))
+
+(= month-names* (obj "january"    1  "jan"        1
+                     "february"   2  "feb"        2
+                     "march"      3  "mar"        3
+                     "april"      4  "apr"        4
+                     "may"        5
+                     "june"       6  "jun"        6
+                     "july"       7  "jul"        7
+                     "august"     8  "aug"        8
+                     "september"  9  "sept"       9  "sep"      9
+                     "october"   10  "oct"       10
+                     "november"  11  "nov"       11
+                     "december"  12  "dec"       12))
+
+(def monthnum (s) (month-names* (downcase s)))
+
+; Doesn't work for BC dates.
+
+(def parse-date (s)
+  (let nums (date-nums s)
+    (if (valid-date nums)
+        nums
+        (err (string "Invalid date: " s)))))
+
+(def date-nums (s)
+  (with ((ynow mnow dnow) (date)
+         toks             (tokens s ~alphadig))
+    (if (all [all digit _] toks)
+         (let nums (map int toks)
+           (case (len nums)
+             1 (list ynow mnow (car nums))
+             2 (iflet d (find [> _ 12] nums)
+                        (list ynow (find [isnt _ d] nums) d)
+                        (cons ynow nums))
+               (if (> (car nums) 31)
+                   (firstn 3 nums)
+                   (rev (firstn 3 nums)))))
+        ([all digit _] (car toks))
+         (withs ((ds ms ys) toks
+                 d          (int ds))
+           (aif (monthnum ms)
+                (list (or (errsafe (int ys)) ynow) 
+                      it
+                      d)
+                nil))
+        (monthnum (car toks))
+         (let (ms ds ys) toks
+           (aif (errsafe (int ds))
+                (list (or (errsafe (int ys)) ynow) 
+                      (monthnum (car toks))
+                      it)
+                nil))
+          nil)))
+
+; To be correct needs to know days per month, and about leap years
+
+(def valid-date ((y m d))
+  (and y m d
+       (< 0 m 13)
+       (< 0 d 32)))
+
+(mac defopl (name parm . body)
+  `(defop ,name ,parm
+     (if (get-user ,parm)
+         (do ,@body) 
+         (login-page 'both
+                     "You need to be logged in to do that."
+                     (list (fn (u ip))
+                           (string ',name (reassemble-args ,parm)))))))
+
diff --git a/lib/arc.arc b/lib/arc.arc
new file mode 100644
index 0000000..ef11fc9
--- /dev/null
+++ b/lib/arc.arc
@@ -0,0 +1,1700 @@
+; Main Arc lib.  Ported to Scheme version Jul 06.
+
+; don't like names of conswhen and consif
+
+; need better way of generating strings; too many calls to string
+;  maybe strings with escape char for evaluation
+; make foo~bar equiv of foo:~bar (in expand-ssyntax)
+; add sigs of ops defined in ac.scm
+; get hold of error types within arc
+; does macex have to be defined in scheme instead of using def below?
+; write disp, read, write in arc
+; could I get all of macros up into arc.arc?
+; warn when shadow a global name
+; some simple regexp/parsing plan
+
+; compromises in this implementation: 
+; no objs in code
+;  (mac testlit args (listtab args)) breaks when called
+; separate string type
+;  (= (cdr (cdr str)) "foo") couldn't work because no way to get str tail
+;  not sure this is a mistake; strings may be subtly different from 
+;  lists of chars
+
+
+(assign do (annotate 'mac
+             (fn args `((fn () ,@args)))))
+
+(assign safeset (annotate 'mac
+                  (fn (var val)
+                    `(do (if (bound ',var)
+                             (do (disp "*** redefining " (stderr))
+                                 (disp ',var (stderr))
+                                 (disp #\newline (stderr))))
+                         (assign ,var ,val)))))
+
+(assign def (annotate 'mac
+               (fn (name parms . body)
+                 `(do (sref sig ',parms ',name)
+                      (safeset ,name (fn ,parms ,@body))))))
+
+(def caar (xs) (car (car xs)))
+(def cadr (xs) (car (cdr xs)))
+(def cddr (xs) (cdr (cdr xs)))
+
+(def no (x) (is x nil))
+
+(def acons (x) (is (type x) 'cons))
+
+(def atom (x) (no (acons x)))
+
+; Can return to this def once Rtm gets ac to make all rest args
+; nil-terminated lists.
+
+; (def list args args)
+
+(def copylist (xs)
+  (if (no xs) 
+      nil 
+      (cons (car xs) (copylist (cdr xs)))))
+
+(def list args (copylist args))
+
+(def idfn (x) x)
+
+; Maybe later make this internal.  Useful to let xs be a fn?
+
+(def map1 (f xs)
+  (if (no xs) 
+      nil
+      (cons (f (car xs)) (map1 f (cdr xs)))))
+
+(def pair (xs (o f list))
+  (if (no xs)
+       nil
+      (no (cdr xs))
+       (list (list (car xs)))
+      (cons (f (car xs) (cadr xs))
+            (pair (cddr xs) f))))
+
+(assign mac (annotate 'mac
+              (fn (name parms . body)
+                `(do (sref sig ',parms ',name)
+                     (safeset ,name (annotate 'mac (fn ,parms ,@body)))))))
+
+(mac and args
+  (if args
+      (if (cdr args)
+          `(if ,(car args) (and ,@(cdr args)))
+          (car args))
+      't))
+
+(def assoc (key al)
+  (if (atom al)
+       nil
+      (and (acons (car al)) (is (caar al) key))
+       (car al)
+      (assoc key (cdr al))))
+
+(def alref (al key) (cadr (assoc key al)))
+
+(mac with (parms . body)
+  `((fn ,(map1 car (pair parms))
+     ,@body)
+    ,@(map1 cadr (pair parms))))
+
+(mac let (var val . body)
+  `(with (,var ,val) ,@body))
+
+(mac withs (parms . body)
+  (if (no parms) 
+      `(do ,@body)
+      `(let ,(car parms) ,(cadr parms) 
+         (withs ,(cddr parms) ,@body))))
+
+; Rtm prefers to overload + to do this
+
+(def join args
+  (if (no args)
+      nil
+      (let a (car args) 
+        (if (no a) 
+            (apply join (cdr args))
+            (cons (car a) (apply join (cdr a) (cdr args)))))))
+
+; Need rfn for use in macro expansions.
+
+(mac rfn (name parms . body)
+  `(let ,name nil
+     (assign ,name (fn ,parms ,@body))))
+
+(mac afn (parms . body)
+  `(let self nil
+     (assign self (fn ,parms ,@body))))
+
+; Ac expands x:y:z into (compose x y z), ~x into (complement x)
+
+; Only used when the call to compose doesn't occur in functional position.  
+; Composes in functional position are transformed away by ac.
+
+(mac compose args
+  (let g (uniq)
+    `(fn ,g
+       ,((afn (fs)
+           (if (cdr fs)
+               (list (car fs) (self (cdr fs)))
+               `(apply ,(if (car fs) (car fs) 'idfn) ,g)))
+         args))))
+
+; Ditto: complement in functional position optimized by ac.
+
+(mac complement (f)
+  (let g (uniq)
+    `(fn ,g (no (apply ,f ,g)))))
+
+(def rev (xs) 
+  ((afn (xs acc)
+     (if (no xs)
+         acc
+         (self (cdr xs) (cons (car xs) acc))))
+   xs nil))
+
+(def isnt (x y) (no (is x y)))
+
+(mac w/uniq (names . body)
+  (if (acons names)
+      `(with ,(apply + nil (map1 (fn (n) (list n '(uniq)))
+                             names))
+         ,@body)
+      `(let ,names (uniq) ,@body)))
+
+(mac or args
+  (and args
+       (w/uniq g
+         `(let ,g ,(car args)
+            (if ,g ,g (or ,@(cdr args)))))))
+
+(def alist (x) (or (no x) (is (type x) 'cons)))
+
+(mac in (x . choices)
+  (w/uniq g
+    `(let ,g ,x
+       (or ,@(map1 (fn (c) `(is ,g ,c)) choices)))))
+
+; Could take n args, but have never once needed that.
+
+(def iso (x y)
+  (or (is x y)
+      (and (acons x) 
+           (acons y) 
+           (iso (car x) (car y)) 
+           (iso (cdr x) (cdr y)))))
+
+(mac when (test . body)
+  `(if ,test (do ,@body)))
+
+(mac unless (test . body)
+  `(if (no ,test) (do ,@body)))
+
+(mac while (test . body)
+  (w/uniq (gf gp)
+    `((rfn ,gf (,gp)
+        (when ,gp ,@body (,gf ,test)))
+      ,test)))
+
+(def empty (seq) 
+  (or (no seq) 
+      (and (or (is (type seq) 'string) (is (type seq) 'table))
+           (is (len seq) 0))))
+
+(def reclist (f xs)
+  (and xs (or (f xs) (reclist f (cdr xs)))))
+
+(def recstring (test s (o start 0))
+  ((afn (i)
+     (and (< i (len s))
+          (or (test i)
+              (self (+ i 1)))))
+   start))
+
+(def testify (x)
+  (if (isa x 'fn) x [is _ x]))
+
+; Like keep, seems like some shouldn't testify.  But find should,
+; and all probably should.
+
+(def some (test seq)
+  (let f (testify test)
+    (if (alist seq)
+        (reclist f:car seq)
+        (recstring f:seq seq))))
+
+(def all (test seq) 
+  (~some (complement (testify test)) seq))
+       
+(def mem (test seq)
+  (let f (testify test)
+    (reclist [if (f:car _) _] seq)))
+
+(def find (test seq)
+  (let f (testify test)
+    (if (alist seq)
+        (reclist   [if (f:car _) (car _)] seq)
+        (recstring [if (f:seq _) (seq _)] seq))))
+
+(def isa (x y) (is (type x) y))
+
+; Possible to write map without map1, but makes News 3x slower.
+
+;(def map (f . seqs)
+;  (if (some1 no seqs)
+;       nil
+;      (no (cdr seqs))
+;       (let s1 (car seqs)
+;         (cons (f (car s1))
+;               (map f (cdr s1))))
+;      (cons (apply f (map car seqs))
+;            (apply map f (map cdr seqs)))))
+
+
+(def map (f . seqs)
+  (if (some [isa _ 'string] seqs) 
+       (withs (n   (apply min (map len seqs))
+               new (newstring n))
+         ((afn (i)
+            (if (is i n)
+                new
+                (do (sref new (apply f (map [_ i] seqs)) i)
+                    (self (+ i 1)))))
+          0))
+      (no (cdr seqs)) 
+       (map1 f (car seqs))
+      ((afn (seqs)
+        (if (some no seqs)  
+            nil
+            (cons (apply f (map1 car seqs))
+                  (self (map1 cdr seqs)))))
+       seqs)))
+
+(def mappend (f . args)
+  (apply + nil (apply map f args)))
+
+(def firstn (n xs)
+  (if (no n)            xs
+      (and (> n 0) xs)  (cons (car xs) (firstn (- n 1) (cdr xs)))
+                        nil))
+
+(def nthcdr (n xs)
+  (if (no n)  xs
+      (> n 0) (nthcdr (- n 1) (cdr xs))
+              xs))
+
+; Generalization of pair: (tuples x) = (pair x)
+
+(def tuples (xs (o n 2))
+  (if (no xs)
+      nil
+      (cons (firstn n xs)
+            (tuples (nthcdr n xs) n))))
+
+; If ok to do with =, why not with def?  But see if use it.
+
+(mac defs args
+  `(do ,@(map [cons 'def _] (tuples args 3))))
+
+(def caris (x val) 
+  (and (acons x) (is (car x) val)))
+
+(def warn (msg . args)
+  (disp (+ "Warning: " msg ". "))
+  (map [do (write _) (disp " ")] args)
+  (disp #\newline))
+
+(mac atomic body
+  `(atomic-invoke (fn () ,@body)))
+
+(mac atlet args
+  `(atomic (let ,@args)))
+  
+(mac atwith args
+  `(atomic (with ,@args)))
+
+(mac atwiths args
+  `(atomic (withs ,@args)))
+
+
+; setforms returns (vars get set) for a place based on car of an expr
+;  vars is a list of gensyms alternating with expressions whose vals they
+;   should be bound to, suitable for use as first arg to withs
+;  get is an expression returning the current value in the place
+;  set is an expression representing a function of one argument
+;   that stores a new value in the place
+
+; A bit gross that it works based on the *name* in the car, but maybe
+; wrong to worry.  Macros live in expression land.
+
+; seems meaningful to e.g. (push 1 (pop x)) if (car x) is a cons.
+; can't in cl though.  could I define a setter for push or pop?
+
+(assign setter (table))
+
+(mac defset (name parms . body)
+  (w/uniq gexpr
+    `(sref setter 
+           (fn (,gexpr)
+             (let ,parms (cdr ,gexpr)
+               ,@body))
+           ',name)))
+
+(defset car (x)
+  (w/uniq g
+    (list (list g x)
+          `(car ,g)
+          `(fn (val) (scar ,g val)))))
+
+(defset cdr (x)
+  (w/uniq g
+    (list (list g x)
+          `(cdr ,g)
+          `(fn (val) (scdr ,g val)))))
+
+(defset caar (x)
+  (w/uniq g
+    (list (list g x)
+          `(caar ,g)
+          `(fn (val) (scar (car ,g) val)))))
+
+(defset cadr (x)
+  (w/uniq g
+    (list (list g x)
+          `(cadr ,g)
+          `(fn (val) (scar (cdr ,g) val)))))
+
+(defset cddr (x)
+  (w/uniq g
+    (list (list g x)
+          `(cddr ,g)
+          `(fn (val) (scdr (cdr ,g) val)))))
+
+; Note: if expr0 macroexpands into any expression whose car doesn't
+; have a setter, setforms assumes it's a data structure in functional 
+; position.  Such bugs will be seen only when the code is executed, when 
+; sref complains it can't set a reference to a function.
+
+(def setforms (expr0)
+  (let expr (macex expr0)
+    (if (isa expr 'sym)
+         (if (ssyntax expr)
+             (setforms (ssexpand expr))
+             (w/uniq (g h)
+               (list (list g expr)
+                     g
+                     `(fn (,h) (assign ,expr ,h)))))
+        ; make it also work for uncompressed calls to compose
+        (and (acons expr) (metafn (car expr)))
+         (setforms (expand-metafn-call (ssexpand (car expr)) (cdr expr)))
+        (and (acons expr) (acons (car expr)) (is (caar expr) 'get))
+         (setforms (list (cadr expr) (cadr (car expr))))
+         (let f (setter (car expr))
+           (if f
+               (f expr)
+               ; assumed to be data structure in fn position
+               (do (when (caris (car expr) 'fn)
+                     (warn "Inverting what looks like a function call"
+                           expr0 expr))
+                   (w/uniq (g h)
+                     (let argsyms (map [uniq] (cdr expr))
+                        (list (+ (list g (car expr))
+                                 (mappend list argsyms (cdr expr)))
+                              `(,g ,@argsyms)
+                              `(fn (,h) (sref ,g ,h ,(car argsyms))))))))))))
+
+(def metafn (x)
+  (or (ssyntax x)
+      (and (acons x) (in (car x) 'compose 'complement))))
+
+(def expand-metafn-call (f args)
+  (if (is (car f) 'compose)
+       ((afn (fs)
+          (if (caris (car fs) 'compose)            ; nested compose
+               (self (join (cdr (car fs)) (cdr fs)))
+              (cdr fs)
+               (list (car fs) (self (cdr fs)))
+              (cons (car fs) args)))
+        (cdr f))
+      (is (car f) 'no)
+       (err "Can't invert " (cons f args))
+       (cons f args)))
+
+(def expand= (place val)
+  (if (and (isa place 'sym) (~ssyntax place))
+      `(assign ,place ,val)
+      (let (vars prev setter) (setforms place)
+        (w/uniq g
+          `(atwith ,(+ vars (list g val))
+             (,setter ,g))))))
+
+(def expand=list (terms)
+  `(do ,@(map (fn ((p v)) (expand= p v))  ; [apply expand= _]
+                  (pair terms))))
+
+(mac = args
+  (expand=list args))
+
+(mac loop (start test update . body)
+  (w/uniq (gfn gparm)
+    `(do ,start
+         ((rfn ,gfn (,gparm) 
+            (if ,gparm
+                (do ,@body ,update (,gfn ,test))))
+          ,test))))
+
+(mac for (v init max . body)
+  (w/uniq (gi gm)
+    `(with (,v nil ,gi ,init ,gm (+ ,max 1))
+       (loop (assign ,v ,gi) (< ,v ,gm) (assign ,v (+ ,v 1))
+         ,@body))))
+
+(mac down (v init min . body)
+  (w/uniq (gi gm)
+    `(with (,v nil ,gi ,init ,gm (- ,min 1))
+       (loop (assign ,v ,gi) (> ,v ,gm) (assign ,v (- ,v 1))
+         ,@body))))
+
+(mac repeat (n . body)
+  `(for ,(uniq) 1 ,n ,@body))
+
+; could bind index instead of gensym
+
+(mac each (var expr . body)
+  (w/uniq (gseq gf gv)
+    `(let ,gseq ,expr
+       (if (alist ,gseq)
+            ((rfn ,gf (,gv)
+               (when (acons ,gv)
+                 (let ,var (car ,gv) ,@body)
+                 (,gf (cdr ,gv))))
+             ,gseq)
+           (isa ,gseq 'table)
+            (maptable (fn ,var ,@body)
+                      ,gseq)
+            (for ,gv 0 (- (len ,gseq) 1)
+              (let ,var (,gseq ,gv) ,@body))))))
+
+; (nthcdr x y) = (cut y x).
+
+(def cut (seq start (o end))
+  (let end (if (no end)   (len seq)
+               (< end 0)  (+ (len seq) end) 
+                          end)
+    (if (isa seq 'string)
+        (let s2 (newstring (- end start))
+          (for i 0 (- end start 1)
+            (= (s2 i) (seq (+ start i))))
+          s2)
+        (firstn (- end start) (nthcdr start seq)))))
+      
+(mac whilet (var test . body)
+  (w/uniq (gf gp)
+    `((rfn ,gf (,gp)
+        (let ,var ,gp
+          (when ,var ,@body (,gf ,test))))
+      ,test)))
+
+(def last (xs)
+  (if (cdr xs)
+      (last (cdr xs))
+      (car xs)))
+
+(def rem (test seq)
+  (let f (testify test)
+    (if (alist seq)
+        ((afn (s)
+           (if (no s)       nil
+               (f (car s))  (self (cdr s))
+                            (cons (car s) (self (cdr s)))))
+          seq)
+        (coerce (rem test (coerce seq 'cons)) 'string))))
+
+; Seems like keep doesn't need to testify-- would be better to
+; be able to use tables as fns.  But rem does need to, because
+; often want to rem a table from a list.  So maybe the right answer
+; is to make keep the more primitive, not rem.
+
+(def keep (test seq) 
+  (rem (complement (testify test)) seq))
+
+;(def trues (f seq) 
+;  (rem nil (map f seq)))
+
+(def trues (f xs)
+  (and xs
+      (let fx (f (car xs))
+        (if fx
+            (cons fx (trues f (cdr xs)))
+            (trues f (cdr xs))))))
+
+(mac do1 args
+  (w/uniq g
+    `(let ,g ,(car args)
+       ,@(cdr args)
+       ,g)))
+
+; Would like to write a faster case based on table generated by a macro,
+; but can't insert objects into expansions in Mzscheme.
+
+(mac caselet (var expr . args)
+  (let ex (afn (args)
+            (if (no (cdr args)) 
+                (car args)
+                `(if (is ,var ',(car args))
+                     ,(cadr args)
+                     ,(self (cddr args)))))
+    `(let ,var ,expr ,(ex args))))
+
+(mac case (expr . args)
+  `(caselet ,(uniq) ,expr ,@args))
+
+(mac push (x place)
+  (w/uniq gx
+    (let (binds val setter) (setforms place)
+      `(let ,gx ,x
+         (atwiths ,binds
+           (,setter (cons ,gx ,val)))))))
+
+(mac swap (place1 place2)
+  (w/uniq (g1 g2)
+    (with ((binds1 val1 setter1) (setforms place1)
+           (binds2 val2 setter2) (setforms place2))
+      `(atwiths ,(+ binds1 (list g1 val1) binds2 (list g2 val2))
+         (,setter1 ,g2)
+         (,setter2 ,g1)))))
+
+(mac rotate places
+  (with (vars (map [uniq] places)
+         forms (map setforms places))
+    `(atwiths ,(mappend (fn (g (binds val setter))
+                          (+ binds (list g val)))
+                        vars
+                        forms)
+       ,@(map (fn (g (binds val setter))
+                (list setter g))
+              (+ (cdr vars) (list (car vars)))
+              forms))))
+
+(mac pop (place)
+  (w/uniq g
+    (let (binds val setter) (setforms place)
+      `(atwiths ,(+ binds (list g val))
+         (do1 (car ,g) 
+              (,setter (cdr ,g)))))))
+
+(def adjoin (x xs (o test iso))
+  (if (some [test x _] xs)
+      xs
+      (cons x xs)))
+
+(mac pushnew (x place . args)
+  (w/uniq gx
+    (let (binds val setter) (setforms place)
+      `(atwiths ,(+ (list gx x) binds)
+         (,setter (adjoin ,gx ,val ,@args))))))
+
+(mac pull (test place)
+  (w/uniq g
+    (let (binds val setter) (setforms place)
+      `(atwiths ,(+ (list g test) binds)
+         (,setter (rem ,g ,val))))))
+
+(mac togglemem (x place . args)
+  (w/uniq gx
+    (let (binds val setter) (setforms place)
+      `(atwiths ,(+ (list gx x) binds)
+         (,setter (if (mem ,gx ,val)
+                      (rem ,gx ,val)
+                      (adjoin ,gx ,val ,@args)))))))
+
+(mac ++ (place (o i 1))
+  (if (isa place 'sym)
+      `(= ,place (+ ,place ,i))
+      (w/uniq gi
+        (let (binds val setter) (setforms place)
+          `(atwiths ,(+ binds (list gi i))
+             (,setter (+ ,val ,gi)))))))
+
+(mac -- (place (o i 1))
+  (if (isa place 'sym)
+      `(= ,place (- ,place ,i))
+      (w/uniq gi
+        (let (binds val setter) (setforms place)
+          `(atwiths ,(+ binds (list gi i))
+             (,setter (- ,val ,gi)))))))
+
+; E.g. (++ x) equiv to (zap + x 1)
+
+(mac zap (op place . args)
+  (with (gop    (uniq)
+         gargs  (map [uniq] args)
+         mix    (afn seqs 
+                  (if (some no seqs)
+                      nil
+                      (+ (map car seqs)
+                         (apply self (map cdr seqs))))))
+    (let (binds val setter) (setforms place)
+      `(atwiths ,(+ binds (list gop op) (mix gargs args))
+         (,setter (,gop ,val ,@gargs))))))
+
+; Can't simply mod pr to print strings represented as lists of chars,
+; because empty string will get printed as nil.  Would need to rep strings
+; as lists of chars annotated with 'string, and modify car and cdr to get
+; the rep of these.  That would also require hacking the reader.  
+
+(def pr args
+  (map1 disp args)
+  (car args))
+
+(def prt args
+  (map1 [if _ (disp _)] args)
+  (car args))
+
+(def prn args
+  (do1 (apply pr args)
+       (writec #\newline)))
+
+(mac wipe args
+  `(do ,@(map (fn (a) `(= ,a nil)) args)))
+
+(mac set args
+  `(do ,@(map (fn (a) `(= ,a t)) args)))
+
+; Destructuring means ambiguity: are pat vars bound in else? (no)
+
+(mac iflet (var expr then . rest)
+  (w/uniq gv
+    `(let ,gv ,expr
+       (if ,gv (let ,var ,gv ,then) ,@rest))))
+
+(mac whenlet (var expr . body)
+  `(iflet ,var ,expr (do ,@body)))
+
+(mac aif (expr . body)
+  `(let it ,expr
+     (if it
+         ,@(if (cddr body)
+               `(,(car body) (aif ,@(cdr body)))
+               body))))
+
+(mac awhen (expr . body)
+  `(let it ,expr (if it (do ,@body))))
+
+(mac aand args
+  (if (no args)
+      't 
+      (no (cdr args))
+       (car args)
+      `(let it ,(car args) (and it (aand ,@(cdr args))))))
+
+(mac accum (accfn . body)
+  (w/uniq gacc
+    `(withs (,gacc nil ,accfn [push _ ,gacc])
+       ,@body
+       (rev ,gacc))))
+
+; Repeatedly evaluates its body till it returns nil, then returns vals.
+
+(mac drain (expr (o eof nil))
+  (w/uniq (gacc gdone gres)
+    `(with (,gacc nil ,gdone nil)
+       (while (no ,gdone)
+         (let ,gres ,expr
+           (if (is ,gres ,eof)
+               (= ,gdone t)
+               (push ,gres ,gacc))))
+       (rev ,gacc))))
+
+; For the common C idiom while x = snarfdata != stopval.
+; Rename this if use it often.
+
+(mac whiler (var expr endval . body)
+  (w/uniq gf
+    `(withs (,var nil ,gf (testify ,endval))
+       (while (no (,gf (= ,var ,expr)))
+         ,@body))))
+  
+;(def macex (e)
+;  (if (atom e)
+;      e
+;      (let op (and (atom (car e)) (eval (car e)))
+;        (if (isa op 'mac)
+;            (apply (rep op) (cdr e))
+;            e))))
+
+(def consif (x y) (if x (cons x y) y))
+
+(def string args
+  (apply + "" (map [coerce _ 'string] args)))
+
+(def flat x
+  ((afn (x acc)
+     (if (no x)   acc
+         (atom x) (cons x acc)
+                  (self (car x) (self (cdr x) acc))))
+   x nil))
+
+(mac check (x test (o alt))
+  (w/uniq gx
+    `(let ,gx ,x
+       (if (,test ,gx) ,gx ,alt))))
+
+(def pos (test seq (o start 0))
+  (let f (testify test)
+    (if (alist seq)
+        ((afn (seq n)
+           (if (no seq)   
+                nil
+               (f (car seq)) 
+                n
+               (self (cdr seq) (+ n 1))))
+         (nthcdr start seq) 
+         start)
+        (recstring [if (f (seq _)) _] seq start))))
+
+(def even (n) (is (mod n 2) 0))
+
+(def odd (n) (no (even n)))
+
+(mac after (x . ys)
+  `(protect (fn () ,x) (fn () ,@ys)))
+
+(let expander 
+     (fn (f var name body)
+       `(let ,var (,f ,name)
+          (after (do ,@body) (close ,var))))
+
+  (mac w/infile (var name . body)
+    (expander 'infile var name body))
+
+  (mac w/outfile (var name . body)
+    (expander 'outfile var name body))
+
+  (mac w/instring (var str . body)
+    (expander 'instring var str body))
+
+  (mac w/socket (var port . body)
+    (expander 'open-socket var port body))
+  )
+
+(mac w/outstring (var . body)
+  `(let ,var (outstring) ,@body))
+
+; what happens to a file opened for append if arc is killed in
+; the middle of a write?
+
+(mac w/appendfile (var name . body)
+  `(let ,var (outfile ,name 'append)
+     (after (do ,@body) (close ,var))))
+
+; rename this simply "to"?  - prob not; rarely use
+
+(mac w/stdout (str . body)
+  `(call-w/stdout ,str (fn () ,@body)))
+
+(mac w/stdin (str . body)
+  `(call-w/stdin ,str (fn () ,@body)))
+
+(mac tostring body
+  (w/uniq gv
+   `(w/outstring ,gv
+      (w/stdout ,gv ,@body)
+      (inside ,gv))))
+
+(mac fromstring (str . body)
+  (w/uniq gv
+   `(w/instring ,gv ,str
+      (w/stdin ,gv ,@body))))
+
+(def readstring1 (s (o eof nil)) (w/instring i s (read i eof)))
+
+(def read ((o x (stdin)) (o eof nil))
+  (if (isa x 'string) (readstring1 x eof) (sread x eof)))
+
+; inconsistency between names of readfile[1] and writefile
+
+(def readfile (name) (w/infile s name (drain (read s))))
+
+(def readfile1 (name) (w/infile s name (read s)))
+
+(def readall (src (o eof nil))
+  ((afn (i)
+    (let x (read i eof)
+      (if (is x eof)
+          nil
+          (cons x (self i)))))
+   (if (isa src 'string) (instring src) src)))
+
+(def allchars (str)
+  (tostring (whiler c (readc str nil) no
+              (writec c))))
+
+(def filechars (name)
+  (w/infile s name (allchars s)))
+
+(def writefile (val file)
+  (let tmpfile (+ file ".tmp")
+    (w/outfile o tmpfile (write val o))
+    (mvfile tmpfile file))
+  val)
+
+(def sym (x) (coerce x 'sym))
+
+(def int (x (o b 10)) (coerce x 'int b))
+
+(mac rand-choice exprs
+  `(case (rand ,(len exprs))
+     ,@(let key -1 
+         (mappend [list (++ key) _]
+                  exprs))))
+
+(mac n-of (n expr)
+  (w/uniq ga
+    `(let ,ga nil     
+       (repeat ,n (push ,expr ,ga))
+       (rev ,ga))))
+
+; rejects bytes >= 248 lest digits be overrepresented
+
+(def rand-string (n)
+  (let c "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
+    (with (nc 62 s (newstring n) i 0)
+      (w/infile str "/dev/urandom"
+        (while (< i n)
+          (let x (readb str)
+             (unless (> x 247)
+               (= (s i) (c (mod x nc)))
+               (++ i)))))
+      s)))
+
+(mac forlen (var s . body)
+  `(for ,var 0 (- (len ,s) 1) ,@body))
+
+(mac on (var s . body)
+  (if (is var 'index)
+      (err "Can't use index as first arg to on.")
+      (w/uniq gs
+        `(let ,gs ,s
+           (forlen index ,gs
+             (let ,var (,gs index)
+               ,@body))))))
+
+(def best (f seq)
+  (if (no seq)
+      nil
+      (let wins (car seq)
+        (each elt (cdr seq)
+          (if (f elt wins) (= wins elt)))
+        wins)))
+              
+(def max args (best > args))
+(def min args (best < args))
+
+; (mac max2 (x y)
+;   (w/uniq (a b)
+;     `(with (,a ,x ,b ,y) (if (> ,a ,b) ,a ,b))))
+
+(def most (f seq) 
+  (unless (no seq)
+    (withs (wins (car seq) topscore (f wins))
+      (each elt (cdr seq)
+        (let score (f elt)
+          (if (> score topscore) (= wins elt topscore score))))
+      wins)))
+
+; Insert so that list remains sorted.  Don't really want to expose
+; these but seem to have to because can't include a fn obj in a 
+; macroexpansion.
+  
+(def insert-sorted (test elt seq)
+  (if (no seq)
+       (list elt) 
+      (test elt (car seq)) 
+       (cons elt seq)
+      (cons (car seq) (insert-sorted test elt (cdr seq)))))
+
+(mac insort (test elt seq)
+  `(zap [insert-sorted ,test ,elt _] ,seq))
+
+(def reinsert-sorted (test elt seq)
+  (if (no seq) 
+       (list elt) 
+      (is elt (car seq))
+       (reinsert-sorted test elt (cdr seq))
+      (test elt (car seq)) 
+       (cons elt (rem elt seq))
+      (cons (car seq) (reinsert-sorted test elt (cdr seq)))))
+
+(mac insortnew (test elt seq)
+  `(zap [reinsert-sorted ,test ,elt _] ,seq))
+
+; Could make this look at the sig of f and return a fn that took the 
+; right no of args and didn't have to call apply (or list if 1 arg).
+
+(def memo (f)
+  (with (cache (table) nilcache (table))
+    (fn args
+      (or (cache args)
+          (and (no (nilcache args))
+               (aif (apply f args)
+                    (= (cache args) it)
+                    (do (set (nilcache args))
+                        nil)))))))
+
+
+(mac defmemo (name parms . body)
+  `(safeset ,name (memo (fn ,parms ,@body))))
+
+(def <= args
+  (or (no args)
+      (no (cdr args))
+      (and (no (> (car args) (cadr args)))
+           (apply <= (cdr args)))))
+
+(def >= args
+  (or (no args)
+      (no (cdr args))
+      (and (no (< (car args) (cadr args)))
+           (apply >= (cdr args)))))
+
+(def whitec (c)
+  (in c #\space #\newline #\tab #\return))
+
+(def nonwhite (c) (no (whitec c)))
+
+(def letter (c) (or (<= #\a c #\z) (<= #\A c #\Z)))
+
+(def digit (c) (<= #\0 c #\9))
+
+(def alphadig (c) (or (letter c) (digit c)))
+
+(def punc (c)
+  (in c #\. #\, #\; #\: #\! #\?))
+
+(def readline ((o str (stdin)))
+  (awhen (readc str)
+    (tostring 
+      (writec it)
+      (whiler c (readc str) [in _ nil #\newline]
+        (writec c)))))
+
+; Don't currently use this but suspect some code could.
+
+(mac summing (sumfn . body)
+  (w/uniq (gc gt)
+    `(let ,gc 0
+       (let ,sumfn (fn (,gt) (if ,gt (++ ,gc)))
+         ,@body)
+       ,gc)))
+
+(def sum (f xs)
+  (let n 0
+    (each x xs (++ n (f x)))
+    n))
+
+(def treewise (f base tree)
+  (if (atom tree)
+      (base tree)
+      (f (treewise f base (car tree)) 
+         (treewise f base (cdr tree)))))
+
+(def carif (x) (if (atom x) x (car x)))
+
+; Could prob be generalized beyond printing.
+
+(def prall (elts (o init "") (o sep ", "))
+  (when elts
+    (pr init (car elts))
+    (map [pr sep _] (cdr elts))
+    elts))
+             
+(def prs args     
+  (prall args "" #\space))
+
+(def tree-subst (old new tree)
+  (if (is tree old)
+       new
+      (atom tree)
+       tree
+      (cons (tree-subst old new (car tree))
+            (tree-subst old new (cdr tree)))))
+
+(def ontree (f tree)
+  (f tree)
+  (unless (atom tree)
+    (ontree f (car tree))
+    (ontree f (cdr tree))))
+
+(def dotted (x)
+  (if (atom x)
+      nil
+      (and (cdr x) (or (atom (cdr x))
+                       (dotted (cdr x))))))
+
+(def fill-table (table data)
+  (each (k v) (pair data) (= (table k) v))
+  table)
+
+(def keys (h) 
+  (accum a (each (k v) h (a k))))
+
+(def vals (h) 
+  (accum a (each (k v) h (a v))))
+
+; These two should really be done by coerce.  Wrap coerce?
+
+(def tablist (h)
+  (accum a (maptable (fn args (a args)) h)))
+
+(def listtab (al)
+  (let h (table)
+    (map (fn ((k v)) (= (h k) v))
+         al)
+    h))
+
+(mac obj args
+  `(listtab (list ,@(map (fn ((k v))
+                           `(list ',k ,v))
+                         (pair args)))))
+
+(def load-table (file (o eof))
+  (w/infile i file (read-table i eof)))
+
+(def read-table ((o i (stdin)) (o eof))
+  (let e (read i eof)
+    (if (alist e) (listtab e) e)))
+
+(def load-tables (file)
+  (w/infile i file
+    (w/uniq eof
+      (drain (read-table i eof) eof))))
+
+(def save-table (h file)
+  (writefile (tablist h) file))
+
+(def write-table (h (o o (stdout)))
+  (write (tablist h) o))
+
+(def copy (x . args)
+  (let x2 (case (type x)
+            sym    x
+            cons   (copylist x) ; (apply (fn args args) x)
+            string (let new (newstring (len x))
+                     (forlen i x
+                       (= (new i) (x i)))
+                     new)
+            table  (let new (table)
+                     (each (k v) x 
+                       (= (new k) v))
+                     new)
+                   (err "Can't copy " x))
+    (map (fn ((k v)) (= (x2 k) v))
+         (pair args))
+    x2))
+
+(def abs (n)
+  (if (< n 0) (- n) n))
+
+; The problem with returning a list instead of multiple values is that
+; you can't act as if the fn didn't return multiple vals in cases where
+; you only want the first.  Not a big problem.
+
+(def round (n)
+  (withs (base (trunc n) rem (abs (- n base)))
+    (if (> rem 1/2) ((if (> n 0) + -) base 1)
+        (< rem 1/2) base
+        (odd base)  ((if (> n 0) + -) base 1)
+                    base)))
+
+(def roundup (n)
+  (withs (base (trunc n) rem (abs (- n base)))
+    (if (>= rem 1/2) 
+        ((if (> n 0) + -) base 1)
+        base)))
+
+(def nearest (n quantum)
+  (* (roundup (/ n quantum)) quantum))
+
+(def avg (ns) (/ (apply + ns) (len ns)))
+
+(def med (ns (o test >))
+  ((sort test ns) (round (/ (len ns) 2))))
+
+; Use mergesort on assumption that mostly sorting mostly sorted lists
+; benchmark: (let td (n-of 10000 (rand 100)) (time (sort < td)) 1) 
+
+(def sort (test seq)
+  (if (alist seq)
+      (mergesort test (copy seq))
+      (coerce (mergesort test (coerce seq 'cons)) (type seq))))
+
+; Destructive stable merge-sort, adapted from slib and improved 
+; by Eli Barzilay for MzLib; re-written in Arc.
+
+(def mergesort (less? lst)
+  (with (n (len lst))
+    (if (<= n 1) lst
+        ; ; check if the list is already sorted
+        ; ; (which can be a common case, eg, directory lists).
+        ; (let loop ([last (car lst)] [next (cdr lst)])
+        ;   (or (null? next)
+        ;       (and (not (less? (car next) last))
+        ;            (loop (car next) (cdr next)))))
+        ; lst
+        ((afn (n)
+           (if (> n 2)
+                ; needs to evaluate L->R
+                (withs (j (/ (if (even n) n (- n 1)) 2) ; faster than round
+                        a (self j)
+                        b (self (- n j)))
+                  (merge less? a b))
+               ; the following case just inlines the length 2 case,
+               ; it can be removed (and use the above case for n>1)
+               ; and the code still works, except a little slower
+               (is n 2)
+                (with (x (car lst) y (cadr lst) p lst)
+                  (= lst (cddr lst))
+                  (when (less? y x) (scar p y) (scar (cdr p) x))
+                  (scdr (cdr p) nil)
+                  p)
+               (is n 1)
+                (with (p lst)
+                  (= lst (cdr lst))
+                  (scdr p nil)
+                  p)
+               nil))
+         n))))
+
+; Also by Eli.
+
+(def merge (less? x y)
+  (if (no x) y
+      (no y) x
+      (let lup nil
+        (assign lup
+                (fn (r x y r-x?) ; r-x? for optimization -- is r connected to x?
+                  (if (less? (car y) (car x))
+                    (do (if r-x? (scdr r y))
+                        (if (cdr y) (lup y x (cdr y) nil) (scdr y x)))
+                    ; (car x) <= (car y)
+                    (do (if (no r-x?) (scdr r x))
+                        (if (cdr x) (lup x (cdr x) y t) (scdr x y))))))
+        (if (less? (car y) (car x))
+          (do (if (cdr y) (lup y x (cdr y) nil) (scdr y x))
+              y)
+          ; (car x) <= (car y)
+          (do (if (cdr x) (lup x (cdr x) y t) (scdr x y))
+              x)))))
+
+(def bestn (n f seq)
+  (firstn n (sort f seq)))
+
+(def split (seq pos)
+  (list (cut seq 0 pos) (cut seq pos)))
+
+(mac time (expr)
+  (w/uniq (t1 t2)
+    `(let ,t1 (msec)
+       (do1 ,expr
+            (let ,t2 (msec)
+              (prn "time: " (- ,t2 ,t1) " msec."))))))
+
+(mac jtime (expr)
+  `(do1 'ok (time ,expr)))
+
+(mac time10 (expr)
+  `(time (repeat 10 ,expr)))
+
+(def union (f xs ys)
+  (+ xs (rem (fn (y) (some [f _ y] xs))
+             ys)))
+
+(= templates* (table))
+
+(mac deftem (tem . fields)
+  (withs (name (carif tem) includes (if (acons tem) (cdr tem)))
+    `(= (templates* ',name) 
+        (+ (mappend templates* ',(rev includes))
+           (list ,@(map (fn ((k v)) `(list ',k (fn () ,v)))
+                        (pair fields)))))))
+
+(mac addtem (name . fields)
+  `(= (templates* ',name) 
+      (union (fn (x y) (is (car x) (car y)))
+             (list ,@(map (fn ((k v)) `(list ',k (fn () ,v)))
+                          (pair fields)))
+             (templates* ',name))))
+
+(def inst (tem . args)
+  (let x (table)
+    (each (k v) (if (acons tem) tem (templates* tem))
+      (unless (no v) (= (x k) (v))))
+    (each (k v) (pair args)
+      (= (x k) v))
+    x))
+
+; To write something to be read by temread, (write (tablist x))
+
+(def temread (tem (o str (stdin)))
+  (templatize tem (read str)))
+
+; Converts alist to inst; ugly; maybe should make this part of coerce.
+; Note: discards fields not defined by the template.
+
+(def templatize (tem raw)
+  (with (x (inst tem) fields (if (acons tem) tem (templates* tem)))
+    (each (k v) raw
+      (when (assoc k fields)
+        (= (x k) v)))
+    x))
+
+(def temload (tem file)
+  (w/infile i file (temread tem i)))
+
+(def temloadall (tem file)
+  (map (fn (pairs) (templatize tem pairs))       
+       (w/infile in file (readall in))))
+
+
+(def number (n) (in (type n) 'int 'num))
+
+(def since (t1) (- (seconds) t1))
+
+(def minutes-since (t1) (/ (since t1) 60))
+(def hours-since (t1)   (/ (since t1) 3600))
+(def days-since (t1)    (/ (since t1) 86400))
+
+; could use a version for fns of 1 arg at least
+
+(def cache (timef valf)
+  (with (cached nil gentime nil)
+    (fn ()
+      (unless (and cached (< (since gentime) (timef)))
+        (= cached  (valf)
+           gentime (seconds)))
+      cached)))
+
+(mac defcache (name lasts . body)
+  `(safeset ,name (cache (fn () ,lasts)
+                         (fn () ,@body))))
+
+(mac errsafe (expr)
+  `(on-err (fn (c) nil)
+           (fn () ,expr)))
+
+(def saferead (arg) (errsafe:read arg))
+
+(def safe-load-table (filename) 
+  (or (errsafe:load-table filename)
+      (table)))
+
+(def ensure-dir (path)
+  (unless (dir-exists path)
+    (system (string "mkdir -p " path))))
+
+(def date ((o s (seconds)))
+  (rev (nthcdr 3 (timedate s))))
+
+(def datestring ((o s (seconds)))
+  (let (y m d) (date s)
+    (string y "-" (if (< m 10) "0") m "-" (if (< d 10) "0") d)))
+
+(def count (test x)
+  (with (n 0 testf (testify test))
+    (each elt x
+      (if (testf elt) (++ n)))
+    n))
+
+(def ellipsize (str (o limit 80))
+  (if (<= (len str) limit)
+      str
+      (+ (cut str 0 limit) "...")))
+
+(def rand-elt (seq) 
+  (seq (rand (len seq))))
+
+(mac until (test . body)
+  `(while (no ,test) ,@body))
+
+(def before (x y seq (o i 0))
+  (with (xp (pos x seq i) yp (pos y seq i))
+    (and xp (or (no yp) (< xp yp)))))
+
+(def orf fns
+  (fn args
+    ((afn (fs)
+       (and fs (or (apply (car fs) args) (self (cdr fs)))))
+     fns)))
+
+(def andf fns
+  (fn args
+    ((afn (fs)
+       (if (no fs)       t
+           (no (cdr fs)) (apply (car fs) args)
+                         (and (apply (car fs) args) (self (cdr fs)))))
+     fns)))
+
+(def atend (i s)
+  (> i (- (len s) 2)))
+
+(def multiple (x y)
+  (is 0 (mod x y)))
+
+(mac nor args `(no (or ,@args))) 
+
+; Consider making the default sort fn take compare's two args (when do 
+; you ever have to sort mere lists of numbers?) and rename current sort
+; as prim-sort or something.
+
+; Could simply modify e.g. > so that (> len) returned the same thing
+; as (compare > len).
+
+(def compare (comparer scorer)
+  (fn (x y) (comparer (scorer x) (scorer y))))
+
+; Cleaner thus, but may only ever need in 2 arg case.
+
+;(def compare (comparer scorer)
+;  (fn args (apply comparer map scorer args)))
+
+; (def only (f g . args) (aif (apply g args) (f it)))
+
+(def only (f) 
+  (fn args (if (car args) (apply f args))))
+
+(mac conswhen (f x y)
+  (w/uniq (gf gx)
+   `(with (,gf ,f ,gx ,x)
+      (if (,gf ,gx) (cons ,gx ,y) ,y))))
+
+; Could combine with firstn if put f arg last, default to (fn (x) t).
+
+(def retrieve (n f xs)
+  (if (no n)                 (keep f xs)
+      (or (<= n 0) (no xs))  nil
+      (f (car xs))           (cons (car xs) (retrieve (- n 1) f (cdr xs)))
+                             (retrieve n f (cdr xs))))
+
+(def dedup (xs)
+  (with (h (table) acc nil)
+    (each x xs
+      (unless (h x)
+        (push x acc)
+        (set (h x))))
+    (rev acc)))
+
+(def single (x) (and (acons x) (no (cdr x))))
+
+(def intersperse (x ys)
+  (and ys (cons (car ys)
+                (mappend [list x _] (cdr ys)))))
+
+(def counts (seq (o c (table)))
+  (if (no seq)
+      c
+      (do (++ (c (car seq) 0))
+          (counts (cdr seq) c))))
+
+(def commonest (seq)
+  (with (winner nil n 0)
+    (each (k v) (counts seq)
+      (when (> v n) (= winner k n v)))
+    (list winner n)))
+
+(def reduce (f xs)
+  (if (cddr xs)
+      (reduce f (cons (f (car xs) (cadr xs)) (cddr xs)))
+      (apply f xs)))
+
+(def rreduce (f xs)
+  (if (cddr xs)
+      (f (car xs) (rreduce f (cdr xs)))
+      (apply f xs)))
+
+(let argsym (uniq)
+
+  (def parse-format (str)
+    (accum a
+      (with (chars nil  i -1)
+        (w/instring s str
+          (whilet c (readc s)
+            (case c 
+              #\# (do (a (coerce (rev chars) 'string))
+                      (wipe chars)
+                      (a (read s)))
+              #\~ (do (a (coerce (rev chars) 'string))
+                      (wipe chars)
+                      (readc s)
+                      (a (list argsym (++ i))))
+                  (push c chars))))
+         (when chars
+           (a (coerce (rev chars) 'string))))))
+  
+  (mac prf (str . args)
+    `(let ,argsym (list ,@args)
+       (pr ,@(parse-format str))))
+)
+
+(def load (file)
+  (w/infile f file
+    (w/uniq eof
+      (whiler e (read f eof) eof
+        (eval e)))))
+
+(def positive (x)
+  (and (number x) (> x 0)))
+
+(mac w/table (var . body)
+  `(let ,var (table) ,@body ,var))
+
+(def ero args
+  (w/stdout (stderr) 
+    (each a args 
+      (write a)
+      (writec #\space))
+    (writec #\newline))
+  (car args))
+
+(def queue () (list nil nil 0))
+
+; Despite call to atomic, once had some sign this wasn't thread-safe.
+; Keep an eye on it.
+
+(def enq (obj q)
+  (atomic
+    (++ (q 2))
+    (if (no (car q))
+        (= (cadr q) (= (car q) (list obj)))
+        (= (cdr (cadr q)) (list obj)
+           (cadr q)       (cdr (cadr q))))
+    (car q)))
+
+(def deq (q)
+  (atomic (unless (is (q 2) 0) (-- (q 2)))
+          (pop (car q))))
+
+; Should redef len to do this, and make queues lists annotated queue.
+
+(def qlen (q) (q 2))
+
+(def qlist (q) (car q))
+
+(def enq-limit (val q (o limit 1000))
+  (atomic
+     (unless (< (qlen q) limit)
+       (deq q))
+     (enq val q)))
+
+(def median (ns)
+  ((sort > ns) (trunc (/ (len ns) 2))))
+
+(mac noisy-each (n var val . body)
+  (w/uniq (gn gc)
+    `(with (,gn ,n ,gc 0)
+       (each ,var ,val
+         (when (multiple (++ ,gc) ,gn)
+           (pr ".") 
+           (flushout)
+           )
+         ,@body)
+       (prn)
+       (flushout))))
+
+(mac point (name . body)
+  (w/uniq (g p)
+    `(ccc (fn (,g)
+            (let ,name (fn ((o ,p)) (,g ,p))
+              ,@body)))))
+
+(mac catch body
+  `(point throw ,@body))
+
+(def downcase (x)
+  (let downc (fn (c)
+               (let n (coerce c 'int)
+                 (if (or (< 64 n 91) (< 191 n 215) (< 215 n 223))
+                     (coerce (+ n 32) 'char)
+                     c)))
+    (case (type x)
+      string (map downc x)
+      char   (downc x)
+      sym    (sym (map downc (coerce x 'string)))
+             (err "Can't downcase" x))))
+
+(def upcase (x)
+  (let upc (fn (c)
+             (let n (coerce c 'int)
+               (if (or (< 96 n 123) (< 223 n 247) (< 247 n 255))
+                   (coerce (- n 32) 'char)
+                   c)))
+    (case (type x)
+      string (map upc x)
+      char   (upc x)
+      sym    (sym (map upc (coerce x 'string)))
+             (err "Can't upcase" x))))
+
+(def inc (x (o n 1))
+  (coerce (+ (coerce x 'int) n) (type x)))
+
+(def range (start end)
+  (if (> start end)
+      nil
+      (cons start (range (inc start) end))))
+
+(def mismatch (s1 s2)
+  (catch
+    (on c s1
+      (when (isnt c (s2 index))
+        (throw index)))))
+
+(def memtable (ks)
+  (let h (table)
+    (each k ks (set (h k)))
+    h))
+
+(= bar* " | ")
+
+(mac w/bars body
+  (w/uniq (out needbars)
+    `(let ,needbars nil
+       (do ,@(map (fn (e)
+                    `(let ,out (tostring ,e)
+                       (unless (is ,out "")
+                         (if ,needbars
+                             (pr bar* ,out)
+                             (do (set ,needbars)
+                                 (pr ,out))))))
+                  body)))))
+
+(def len< (x n) (< (len x) n))
+
+(def len> (x n) (> (len x) n))
+
+(mac thread body 
+  `(new-thread (fn () ,@body)))
+
+(mac trav (x . fs)
+  (w/uniq g
+    `((afn (,g)
+        (when ,g
+          ,@(map [list _ g] fs)))
+      ,x)))
+
+(mac or= (place expr)
+  (let (binds val setter) (setforms place)
+    `(atwiths ,binds
+       (or ,val (,setter ,expr)))))
+
+(= hooks* (table))
+
+(def hook (name . args)
+  (aif (hooks* name) (apply it args)))
+
+(mac defhook (name . rest)
+  `(= (hooks* ',name) (fn ,@rest)))
+  
+(mac out (expr) `(pr ,(tostring (eval expr))))
+
+; if renamed this would be more natural for (map [_ user] pagefns*)
+
+(def get (index) [_ index])
+
+(= savers* (table))
+
+(mac fromdisk (var file init load save)
+  (w/uniq (gf gv)
+    `(unless (bound ',var)
+       (do1 (= ,var (iflet ,gf (file-exists ,file)
+                               (,load ,gf)
+                               ,init))
+            (= (savers* ',var) (fn (,gv) (,save ,gv ,file)))))))
+
+(mac diskvar (var file)
+  `(fromdisk ,var ,file nil readfile1 writefile))
+
+(mac disktable (var file)
+  `(fromdisk ,var ,file (table) load-table save-table))
+
+(mac todisk (var (o expr var))
+  `((savers* ',var) 
+    ,(if (is var expr) var `(= ,var ,expr))))
+
+
+(mac evtil (expr test)
+  (w/uniq gv
+    `(let ,gv ,expr
+       (while (no (,test ,gv))
+         (= ,gv ,expr))
+       ,gv)))
+
+(def rand-key (h)
+  (if (empty h)
+      nil
+      (let n (rand (len h))
+        (catch
+          (each (k v) h
+            (when (is (-- n) -1)
+              (throw k)))))))
+
+(def ratio (test xs)
+  (if (empty xs)
+      0
+      (/ (count test xs) (len xs))))
+
+
+; any logical reason I can't say (push x (if foo y z)) ?
+;   eval would have to always ret 2 things, the val and where it came from
+; idea: implicit tables of tables; setf empty field, becomes table
+;   or should setf on a table just take n args?
+
+; idea: use constants in functional position for currying?
+;       (1 foo) would mean (fn args (apply foo 1 args))
+; another solution would be to declare certain symbols curryable, and 
+;  if > was, >_10 would mean [> _ 10]
+;  or just say what the hell and make _ ssyntax for currying
+; idea: make >10 ssyntax for [> _ 10]
+; solution to the "problem" of improper lists: allow any atom as a list
+;  terminator, not just nil.  means list recursion should terminate on 
+;  atom rather than nil, (def empty (x) (or (atom x) (is x "")))
+; table should be able to take an optional initial-value.  handle in sref.
+; warn about code of form (if (= )) -- probably mean is
+; warn when a fn has a parm that's already defined as a macro.
+;   (def foo (after) (after))
+; idea: a fn (nothing) that returns a special gensym which is ignored
+;  by map, so can use map in cases when don't want all the vals
+; idea: anaph macro so instead of (aand x y) say (anaph and x y)
+; idea: foo.bar!baz as an abbrev for (foo bar 'baz)
+;  or something a bit more semantic?
+; could uniq be (def uniq () (annotate 'symbol (list 'u))) again?
+; idea: use x- for (car x) and -x for (cdr x)  (but what about math -?)
+; idea: get rid of strings and just use symbols
+; could a string be (#\a #\b . "") ?
+; better err msg when , outside of a bq
+; idea: parameter (p foo) means in body foo is (pair arg)
+; idea: make ('string x) equiv to (coerce x 'string) ?  or isa?
+;   quoted atoms in car valuable unused semantic space
+; idea: if (defun foo (x y) ...), make (foo 1) return (fn (y) (foo 1 y))
+;   probably would lead to lots of errors when call with missing args
+;   but would be really dense with . notation, (foo.1 2)
+; or use special ssyntax for currying: (foo@1 2)
+; remember, can also double; could use foo::bar to mean something
+; wild idea: inline defs for repetitive code
+;  same args as fn you're in
+; variant of compose where first fn only applied to first arg?
+;  (> (len x) y)  means (>+len x y)
+; use ssyntax underscore for a var?
+;  foo_bar means [foo _ bar]
+;  what does foo:_:bar mean?
+; matchcase
+; idea: atable that binds it to table, assumes input is a list
+; crazy that finding the top 100 nos takes so long:
+;  (let bb (n-of 1000 (rand 50)) (time10 (bestn 100 > bb)))
+;  time: 2237 msec.  -> now down to 850 msec
+
diff --git a/lib/blog.arc b/lib/blog.arc
new file mode 100644
index 0000000..211dd63
--- /dev/null
+++ b/lib/blog.arc
@@ -0,0 +1,95 @@
+; Blog tool example.  20 Jan 08, rev 21 May 09.
+
+; To run:
+; arc> (load "blog.arc")
+; arc> (bsv)
+; go to http://localhost:8080/blog
+
+(= postdir* "arc/posts/"  maxid* 0  posts* (table))
+
+(= blogtitle* "A Blog")
+
+(deftem post  id nil  title nil  text nil)
+
+(def load-posts ()
+  (each id (map int (dir postdir*))
+    (= maxid*      (max maxid* id)
+       (posts* id) (temload 'post (string postdir* id)))))
+
+(def save-post (p) (save-table p (string postdir* p!id)))
+
+(def post (id) (posts* (errsafe:int id)))
+
+(mac blogpage body
+  `(whitepage 
+     (center
+       (widtable 600 
+         (tag b (link blogtitle* "blog"))
+         (br 3)
+         ,@body
+         (br 3)
+         (w/bars (link "archive")
+                 (link "new post" "newpost"))))))
+
+(defop viewpost req (blogop post-page req))
+
+(def blogop (f req)
+  (aif (post (arg req "id")) 
+       (f (get-user req) it) 
+       (blogpage (pr "No such post."))))
+
+(def permalink (p) (string "viewpost?id=" p!id))
+
+(def post-page (user p) (blogpage (display-post user p)))
+
+(def display-post (user p)
+  (tag b (link p!title (permalink p)))
+  (when user
+    (sp)
+    (link "[edit]" (string "editpost?id=" p!id)))
+  (br2)
+  (pr p!text))
+
+(defopl newpost req
+  (whitepage
+    (aform [let u (get-user _)
+             (post-page u (addpost u (arg _ "t") (arg _ "b")))]
+      (tab (row "title" (input "t" "" 60))
+           (row "text"  (textarea "b" 10 80))
+           (row ""      (submit))))))
+
+(def addpost (user title text)
+  (let p (inst 'post 'id (++ maxid*) 'title title 'text text)
+    (save-post p)
+    (= (posts* p!id) p)))
+
+(defopl editpost req (blogop edit-page req))
+
+(def edit-page (user p)
+  (whitepage
+    (vars-form user
+               `((string title ,p!title t t) (text text ,p!text t t))
+               (fn (name val) (= (p name) val))
+               (fn () (save-post p)
+                      (post-page user p)))))
+
+(defop archive req
+  (blogpage
+    (tag ul
+      (each p (map post (rev (range 1 maxid*)))
+        (tag li (link p!title (permalink p)))))))
+
+(defop blog req
+  (let user (get-user req)
+    (blogpage
+      (for i 0 4
+        (awhen (posts* (- maxid* i)) 
+          (display-post user it)
+          (br 3))))))
+
+(def bsv ()
+  (ensure-dir postdir*)
+  (load-posts)
+  (asv))
+
+
diff --git a/lib/code.arc b/lib/code.arc
new file mode 100644
index 0000000..cf1e280
--- /dev/null
+++ b/lib/code.arc
@@ -0,0 +1,61 @@
+; Code analysis. Spun off 21 Dec 07.
+
+; Ought to do more of this in Arc.  One of the biggest advantages
+; of Lisp is messing with code.
+
+(def codelines (file)
+  (w/infile in file
+    (summing test
+      (whilet line (readline in)
+        (test (aand (find nonwhite line) (isnt it #\;)))))))
+
+(def codeflat (file)
+  (len (flat (readall (infile file)))))
+
+(def codetree (file)
+  (treewise + (fn (x) 1) (readall (infile file))))
+
+(def code-density (file)
+  (/ (codetree file) (codelines file))) 
+
+(def tokcount (files)
+  (let counts (table)
+    (each f files
+      (each token (flat (readall (infile f)))
+        (++ (counts token 0))))
+    counts))
+
+(def common-tokens (files)
+  (let counts (tokcount files)
+    (let ranking nil
+      (maptable (fn (k v)
+                  (unless (nonop k)
+                    (insort (compare > cadr) (list k v) ranking)))
+                counts)
+      ranking)))
+
+(def nonop (x)
+  (in x 'quote 'unquote 'quasiquote 'unquote-splicing))
+
+(def common-operators (files)
+  (keep [and (isa (car _) 'sym) (bound (car _))] (common-tokens files)))
+
+(def top40 (xs)
+  (map prn (firstn 40 xs))
+  t)
+
+(def space-eaters (files)
+  (let counts (tokcount files)
+    (let ranking nil
+      (maptable (fn (k v)
+                  (when (and (isa k 'sym) (bound k))
+                    (insort (compare > [* (len (string (car _)))
+                                          (cadr _)])
+                            (list k v (* (len (string k)) v))
+                            ranking)))
+                counts)
+    ranking)))
+
+;(top40 (space-eaters allfiles*))
+
+(mac flatlen args `(len (flat ',args)))
diff --git a/lib/copyright b/lib/copyright
new file mode 100644
index 0000000..c608ea0
--- /dev/null
+++ b/lib/copyright
@@ -0,0 +1,2 @@
+This software is copyright (c) Paul Graham and Robert Morris.  Permission
+to use it is granted under the Perl Foundations's Artistic License 2.0.
diff --git a/lib/html.arc b/lib/html.arc
new file mode 100644
index 0000000..981dfaa
--- /dev/null
+++ b/lib/html.arc
@@ -0,0 +1,415 @@
+; HTML Utils. 
+
+
+(def color (r g b)
+  (with (c (table) 
+         f (fn (x) (if (< x 0) 0 (> x 255) 255 x)))
+    (= (c 'r) (f r) (c 'g) (f g) (c 'b) (f b))
+    c))
+
+(def dehex (str) (errsafe (coerce str 'int 16)))
+
+(defmemo hex>color (str)
+  (and (is (len str) 6)
+       (with (r (dehex (cut str 0 2))
+              g (dehex (cut str 2 4))
+              b (dehex (cut str 4 6)))
+         (and r g b
+              (color r g b)))))
+
+(defmemo gray (n) (color n n n))
+
+(= white    (gray 255) 
+   black    (gray 0)
+   linkblue (color 0 0 190)
+   orange   (color 255 102 0)
+   darkred  (color 180 0 0)
+   darkblue (color 0 0 120)
+   )
+
+(= opmeths* (table))
+
+(mac opmeth args
+  `(opmeths* (list ,@args)))
+
+(mac attribute (tag opt f)
+  `(= (opmeths* (list ',tag ',opt)) ,f))
+
+(= hexreps (table))
+
+(for i 0 255 (= (hexreps i)
+                (let s (coerce i 'string 16)
+                  (if (is (len s) 1) (+ "0" s) s))))
+
+(defmemo hexrep (col)
+  (+ (hexreps (col 'r)) (hexreps (col 'g)) (hexreps (col 'b))))
+
+(def opcolor (key val) 
+  (w/uniq gv
+    `(whenlet ,gv ,val
+       (pr ,(string " " key "=#") (hexrep ,gv)))))
+
+(def opstring (key val)
+  `(aif ,val (pr ,(+ " " key "=\"") it #\")))
+
+(def opnum (key val)
+  `(aif ,val (pr ,(+ " " key "=") it)))
+
+(def opsym (key val)
+  `(pr ,(+ " " key "=") ,val))
+
+(def opsel (key val)
+  `(if ,val (pr " selected")))
+
+(def opcheck (key val)
+  `(if ,val (pr " checked")))
+
+(def opesc (key val)
+  `(awhen ,val
+     (pr ,(string " " key "=\""))
+     (if (isa it 'string) (pr-escaped it) (pr it))
+     (pr  #\")))
+
+; need to escape more?  =?
+
+(def pr-escaped (x)
+  (each c x 
+    (pr (case c #\<  "&#60;"  
+                #\>  "&#62;"  
+                #\"  "&#34;"  
+                #\&  "&#38;"
+                c))))
+
+(attribute a          href           opstring)
+(attribute a          rel            opstring)
+(attribute a          class          opstring)
+(attribute a          id             opsym)
+(attribute a          onclick        opstring)
+(attribute body       alink          opcolor)
+(attribute body       bgcolor        opcolor)
+(attribute body       leftmargin     opnum)
+(attribute body       link           opcolor)
+(attribute body       marginheight   opnum)
+(attribute body       marginwidth    opnum)
+(attribute body       topmargin      opnum)
+(attribute body       vlink          opcolor)
+(attribute font       color          opcolor)
+(attribute font       face           opstring)
+(attribute font       size           opnum)
+(attribute form       action         opstring)
+(attribute form       method         opsym)
+(attribute img        align          opsym)
+(attribute img        border         opnum)
+(attribute img        height         opnum)
+(attribute img        width          opnum)
+(attribute img        vspace         opnum)
+(attribute img        hspace         opnum)
+(attribute img        src            opstring)
+(attribute input      name           opstring)
+(attribute input      size           opnum)
+(attribute input      type           opsym)
+(attribute input      value          opesc)
+(attribute input      checked        opcheck)
+(attribute select     name           opstring)
+(attribute option     selected       opsel)
+(attribute table      bgcolor        opcolor)
+(attribute table      border         opnum)
+(attribute table      cellpadding    opnum)
+(attribute table      cellspacing    opnum)
+(attribute table      width          opstring)
+(attribute textarea   cols           opnum)
+(attribute textarea   name           opstring)
+(attribute textarea   rows           opnum)
+(attribute textarea   wrap           opsym)
+(attribute td         align          opsym)
+(attribute td         bgcolor        opcolor)
+(attribute td         colspan        opnum)
+(attribute td         width          opnum)
+(attribute td         valign         opsym)
+(attribute td         class          opstring)
+(attribute tr         bgcolor        opcolor)
+(attribute hr         color          opcolor)
+(attribute span       class          opstring)
+(attribute span       align          opstring)
+(attribute span       id             opsym)
+(attribute rss        version        opstring)
+
+
+(mac gentag args (start-tag args))
+     
+(mac tag (spec . body)
+  `(do ,(start-tag spec)
+       ,@body
+       ,(end-tag spec)))
+     
+(mac tag-if (test spec . body)
+  `(if ,test
+       (tag ,spec ,@body)
+       (do ,@body)))
+
+(def start-tag (spec)
+  (if (atom spec)
+      `(pr ,(string "<" spec ">"))
+      (let opts (tag-options (car spec) (pair (cdr spec)))
+        (if (all [isa _ 'string] opts)
+            `(pr ,(string "<" (car spec) (apply string opts) ">"))
+            `(do (pr ,(string "<" (car spec)))
+                 ,@(map (fn (opt)
+                          (if (isa opt 'string)
+                              `(pr ,opt)
+                              opt))
+                        opts)
+                 (pr ">"))))))
+
+(def end-tag (spec)
+  `(pr ,(string "</" (carif spec) ">")))
+
+(def literal (x) 
+  (case (type x)
+    sym   (in x nil t)
+    cons  (caris x 'quote)
+          t))
+
+; Returns a list whose elements are either strings, which can 
+; simply be printed out, or expressions, which when evaluated
+; generate output.
+
+(def tag-options (spec options)
+  (if (no options)
+      '()
+      (let ((opt val) . rest) options
+        (let meth (if (is opt 'style) opstring (opmeth spec opt))
+          (if meth
+              (if val
+                  (cons (if (precomputable-tagopt val)
+                            (tostring (eval (meth opt val)))
+                            (meth opt val))
+                        (tag-options spec rest))
+                  (tag-options spec rest))
+              (do
+                (pr "<!-- ignoring " opt " for " spec "-->")
+                (tag-options spec rest)))))))
+
+(def precomputable-tagopt (val)
+  (and (literal val) 
+       (no (and (is (type val) 'string) (find #\@ val)))))
+
+(def br ((o n 1)) 
+  (repeat n (pr "<br>")) 
+  (prn))
+
+(def br2 () (prn "<br><br>"))
+
+(mac center    body         `(tag center ,@body))
+(mac underline body         `(tag u ,@body))
+(mac tab       body         `(tag (table border 0) ,@body))
+(mac tr        body         `(tag tr ,@body))
+
+(let pratoms (fn (body)
+               (if (or (no body) 
+                       (all [and (acons _) (isnt (car _) 'quote)]
+                            body))
+                   body
+                   `((pr ,@body))))
+
+  (mac td       body         `(tag td ,@(pratoms body)))
+  (mac trtd     body         `(tr (td ,@(pratoms body))))
+  (mac tdr      body         `(tag (td align 'right) ,@(pratoms body)))
+  (mac tdcolor  (col . body) `(tag (td bgcolor ,col) ,@(pratoms body)))
+)
+
+(mac row args
+  `(tr ,@(map [list 'td _] args)))
+
+(mac prrow args
+  (w/uniq g
+    `(tr ,@(map (fn (a) 
+                  `(let ,g ,a
+                     (if (number ,g)
+                         (tdr (pr ,g))
+                         (td (pr ,g)))))
+                 args))))
+
+(mac prbold body `(tag b (pr ,@body)))
+
+(def para args 
+  (gentag p)
+  (when args (apply pr args)))
+
+(def menu (name items (o sel nil))
+  (tag (select name name)
+    (each i items
+      (tag (option selected (is i sel))
+        (pr i)))))
+
+(mac whitepage body
+  `(tag html 
+     (tag (body bgcolor white alink linkblue) ,@body)))
+
+(def errpage args (whitepage (apply prn args)))
+
+(def blank-url () "s.gif")
+
+; Could memoize these.
+
+; If h = 0, doesn't affect table column widths in some Netscapes.
+
+(def hspace (n)    (gentag img src (blank-url) height 1 width n))
+(def vspace (n)    (gentag img src (blank-url) height n width 0))
+(def vhspace (h w) (gentag img src (blank-url) height h width w))
+
+(mac new-hspace (n)    
+  (if (number n)
+      `(pr ,(string "<span style=\"padding-left:" n "px\" />"))
+      `(pr "<span style=\"padding-left:" ,n "px\" />")))
+
+;(def spacerow (h) (tr (td (vspace h))))
+
+(def spacerow (h) (pr "<tr style=\"height:" h "px\"></tr>"))
+
+; For use as nested table.
+
+(mac zerotable body
+  `(tag (table border 0 cellpadding 0 cellspacing 0)
+     ,@body))
+
+; was `(tag (table border 0 cellpadding 0 cellspacing 7) ,@body)
+
+(mac sptab body
+  `(tag (table style "border-spacing: 7px 0px;") ,@body))
+
+(mac widtable (w . body)
+  `(tag (table width ,w) (tr (td ,@body))))
+
+(def cellpr (x) (pr (or x "&nbsp;")))
+
+(def but ((o text "submit") (o name nil))
+  (gentag input type 'submit name name value text))
+
+(def submit ((o val "submit"))
+  (gentag input type 'submit value val))
+
+(def buts (name . texts)
+  (if (no texts)
+      (but)
+      (do (but (car texts) name)
+          (each text (cdr texts)
+            (pr " ")
+            (but text name)))))
+
+(mac spanrow (n . body)
+  `(tr (tag (td colspan ,n) ,@body)))
+
+(mac form (action . body)
+  `(tag (form method "post" action ,action) ,@body))
+
+(mac textarea (name rows cols . body)
+  `(tag (textarea name ,name rows ,rows cols ,cols) ,@body))
+
+(def input (name (o val "") (o size 10))
+  (gentag input type 'text name name value val size size))
+
+(mac inputs args
+  `(tag (table border 0)
+     ,@(map (fn ((name label len text))
+              (w/uniq (gl gt)
+                `(let ,gl ,len
+                   (tr (td (pr ',label ":"))
+                       (if (isa ,gl 'cons)
+                           (td (textarea ',name (car ,gl) (cadr ,gl)
+                                 (let ,gt ,text (if ,gt (pr ,gt)))))
+                           (td (gentag input type ',(if (is label 'password) 
+                                                    'password 
+                                                    'text)
+                                         name ',name 
+                                         size ,len 
+                                         value ,text)))))))
+            (tuples args 4))))
+
+(def single-input (label name chars btext (o pwd))
+  (pr label)
+  (gentag input type (if pwd 'password 'text) name name size chars)
+  (sp)
+  (submit btext))
+
+(mac cdata body
+  `(do (pr "<![CDATA[") 
+       ,@body
+       (pr "]]>")))
+
+(def eschtml (str)
+  (tostring 
+    (each c str
+      (pr (case c #\<  "&#60;" 
+                  #\>  "&#62;"
+                  #\"  "&#34;"
+                  #\'  "&#39;"
+                  #\&  "&#38;"
+                        c)))))
+
+(def esc-tags (str)
+  (tostring 
+    (each c str
+      (pr (case c #\<  "&#60;" 
+                  #\>  "&#62;"
+                  #\&  "&#38;"
+                        c)))))
+
+(def nbsp () (pr "&nbsp;"))
+
+(def link (text (o dest text) (o color))
+  (tag (a href dest) 
+    (tag-if color (font color color)
+      (pr text))))
+
+(def underlink (text (o dest text))
+  (tag (a href dest) (tag u (pr text))))
+
+(def striptags (s)
+  (let intag nil
+    (tostring
+      (each c s
+        (if (is c #\<) (set intag)
+            (is c #\>) (wipe intag)
+            (no intag) (pr c))))))
+
+(def clean-url (u)
+  (rem [in _ #\" #\' #\< #\>] u))
+
+(def shortlink (url)
+  (unless (or (no url) (< (len url) 7))
+    (link (cut url 7) url)))
+
+; this should be one regexp
+
+(def parafy (str)
+  (let ink nil
+    (tostring
+      (each c str
+        (pr c)
+        (unless (whitec c) (set ink))
+        (when (is c #\newline)
+          (unless ink (pr "<p>"))
+          (wipe ink))))))
+
+(mac spanclass (name . body)
+  `(tag (span class ',name) ,@body))
+
+(def pagemessage (text)
+  (when text (prn text) (br2)))
+
+; Could be stricter.  Memoized because looking for chars in Unicode
+; strings is terribly inefficient in Mzscheme.
+
+(defmemo valid-url (url)
+  (and (len> url 10)
+       (or (begins url "http://")
+           (begins url "https://"))
+       (~find [in _ #\< #\> #\" #\'] url)))
+
+(mac fontcolor (c . body)
+  (w/uniq g
+    `(let ,g ,c
+       (if ,g
+           (tag (font color ,g) ,@body)
+           (do ,@body)))))
diff --git a/lib/libs.arc b/lib/libs.arc
new file mode 100644
index 0000000..68b5d9b
--- /dev/null
+++ b/lib/libs.arc
@@ -0,0 +1,7 @@
+(map load '("strings.arc"
+            "pprint.arc"
+            "code.arc"
+            "html.arc"
+            "srv.arc"
+            "app.arc"
+            "prompt.arc"))
diff --git a/lib/news.arc b/lib/news.arc
new file mode 100644
index 0000000..e837d64
--- /dev/null
+++ b/lib/news.arc
@@ -0,0 +1,2617 @@
+; News.  2 Sep 06.
+
+; to run news: (nsv), then go to http://localhost:8080
+; put usernames of admins, separated by whitespace, in arc/admins
+
+; bug: somehow (+ votedir* nil) is getting evaluated.
+
+(declare 'atstrings t)
+
+(= this-site*    "My Forum"
+   site-url*     "http://news.yourdomain.com/"
+   parent-url*   "http://www.yourdomain.com"
+   favicon-url*  ""
+   site-desc*    "What this site is about."               ; for rss feed
+   site-color*   (color 180 180 180)
+   border-color* (color 180 180 180)
+   prefer-url*   t)
+
+
+; Structures
+
+; Could add (html) types like choice, yesno to profile fields.  But not 
+; as part of deftem, which is defstruct.  Need another mac on top of 
+; deftem.  Should not need the type specs in user-fields.
+
+(deftem profile
+  id         nil
+  name       nil
+  created    (seconds)
+  auth       0
+  member     nil
+  submitted  nil
+  votes      nil   ; for now just recent, elts each (time id by sitename dir)
+  karma      1
+  avg        nil
+  weight     .5
+  ignore     nil
+  email      nil
+  about      nil
+  showdead   nil
+  noprocrast nil
+  firstview  nil
+  lastview   nil
+  maxvisit   20 
+  minaway    180
+  topcolor   nil
+  keys       nil
+  delay      0)
+
+(deftem item
+  id         nil
+  type       nil
+  by         nil
+  ip         nil
+  time       (seconds)
+  url        nil
+  title      nil
+  text       nil
+  votes      nil   ; elts each (time ip user type score)
+  score      0
+  sockvotes  0
+  flags      nil
+  dead       nil
+  deleted    nil
+  parts      nil
+  parent     nil
+  kids       nil
+  keys       nil)
+
+
+; Load and Save
+
+(= newsdir*  "arc/news/"
+   storydir* "arc/news/story/"
+   profdir*  "arc/news/profile/"
+   votedir*  "arc/news/vote/")
+
+(= votes* (table) profs* (table))
+
+(= initload-users* nil)
+
+(def nsv ((o port 8080))
+  (map ensure-dir (list arcdir* newsdir* storydir* votedir* profdir*))
+  (unless stories* (load-items))
+  (if (and initload-users* (empty profs*)) (load-users))
+  (asv port))
+
+(def load-users ()
+  (pr "load users: ")
+  (noisy-each 100 id (dir profdir*)
+    (load-user id)))
+
+; For some reason vote files occasionally get written out in a 
+; broken way.  The nature of the errors (random missing or extra
+; chars) suggests the bug is lower-level than anything in Arc.
+; Which unfortunately means all lists written to disk are probably
+; vulnerable to it, since that's all save-table does.
+
+(def load-user (u)
+  (= (votes* u) (load-table (+ votedir* u))
+     (profs* u) (temload 'profile (+ profdir* u)))
+  u)
+
+; Have to check goodname because some user ids come from http requests.
+; So this is like safe-item.  Don't need a sep fn there though.
+
+(def profile (u)
+  (or (profs* u)
+      (aand (goodname u)
+            (file-exists (+ profdir* u))
+            (= (profs* u) (temload 'profile it)))))
+
+(def votes (u)
+  (or (votes* u)
+      (aand (file-exists (+ votedir* u))
+            (= (votes* u) (load-table it)))))
+          
+(def init-user (u)
+  (= (votes* u) (table) 
+     (profs* u) (inst 'profile 'id u))
+  (save-votes u)
+  (save-prof u)
+  u)
+
+; Need this because can create users on the server (for other apps)
+; without setting up places to store their state as news users.
+; See the admin op in app.arc.  So all calls to login-page from the 
+; news app need to call this in the after-login fn.
+
+(def ensure-news-user (u)
+  (if (profile u) u (init-user u)))
+
+(def save-votes (u) (save-table (votes* u) (+ votedir* u)))
+
+(def save-prof  (u) (save-table (profs* u) (+ profdir* u)))
+
+(mac uvar (u k) `((profile ,u) ',k))
+
+(mac karma   (u) `(uvar ,u karma))
+(mac ignored (u) `(uvar ,u ignore))
+
+; Note that users will now only consider currently loaded users.
+
+(def users ((o f idfn)) 
+  (keep f (keys profs*)))
+
+(def check-key (u k)
+  (and u (mem k (uvar u keys))))
+
+(def author (u i) (is u i!by))
+
+
+(= stories* nil comments* nil 
+   items* (table) url->story* (table)
+   maxid* 0 initload* 15000)
+
+; The dir expression yields stories in order of file creation time 
+; (because arc infile truncates), so could just rev the list instead of
+; sorting, but sort anyway.
+
+; Note that stories* etc only include the initloaded (i.e. recent)
+; ones, plus those created since this server process started.
+
+; Could be smarter about preloading by keeping track of popular pages.
+
+(def load-items ()
+  (system (+ "rm " storydir* "*.tmp"))
+  (pr "load items: ") 
+  (with (items (table)
+         ids   (sort > (map int (dir storydir*))))
+    (if ids (= maxid* (car ids)))
+    (noisy-each 100 id (firstn initload* ids)
+      (let i (load-item id)
+        (push i (items i!type))))
+    (= stories*  (rev (merge (compare < !id) items!story items!poll))
+       comments* (rev items!comment))
+    (hook 'initload items))
+  (ensure-topstories))
+
+(def ensure-topstories ()
+  (aif (errsafe (readfile1 (+ newsdir* "topstories")))
+       (= ranked-stories* (map item it))
+       (do (prn "ranking stories.") 
+           (flushout)
+           (gen-topstories))))
+
+(def astory   (i) (is i!type 'story))
+(def acomment (i) (is i!type 'comment))
+(def apoll    (i) (is i!type 'poll))
+
+(def load-item (id)
+  (let i (temload 'item (+ storydir* id))
+    (= (items* id) i)
+    (awhen (and (astory&live i) (check i!url ~blank))
+      (register-url i it))
+    i))
+
+; Note that duplicates are only prevented of items that have at some 
+; point been loaded. 
+
+(def register-url (i url)
+  (= (url->story* (canonical-url url)) i!id))
+
+; redefined later
+
+(= stemmable-sites* (table))
+
+(def canonical-url (url)
+  (if (stemmable-sites* (sitename url))
+      (cut url 0 (pos #\? url))
+      url))
+
+(def new-item-id ()
+  (evtil (++ maxid*) [~file-exists (+ storydir* _)]))
+
+(def item (id)
+  (or (items* id) (errsafe:load-item id)))
+
+(def kids (i) (map item i!kids))
+
+; For use on external item references (from urls).  Checks id is int 
+; because people try e.g. item?id=363/blank.php
+
+(def safe-item (id)
+  (ok-id&item (if (isa id 'string) (saferead id) id)))
+
+(def ok-id (id) 
+  (and (exact id) (<= 1 id maxid*)))
+
+(def arg->item (req key)
+  (safe-item:saferead (arg req key)))
+
+(def live (i) (nor i!dead i!deleted))
+
+(def save-item (i) (save-table i (+ storydir* i!id)))
+
+(def kill (i how)
+  (unless i!dead
+    (log-kill i how)
+    (wipe (comment-cache* i!id))
+    (set i!dead)
+    (save-item i)))
+
+(= kill-log* nil)
+
+(def log-kill (i how)
+  (push (list i!id how) kill-log*))
+
+(mac each-loaded-item (var . body)
+  (w/uniq g
+    `(let ,g nil
+       (loop (= ,g maxid*) (> ,g 0) (-- ,g)
+         (whenlet ,var (items* ,g)
+           ,@body)))))
+
+(def loaded-items (test)
+  (accum a (each-loaded-item i (test&a i))))
+
+(def newslog args (apply srvlog 'news args))
+
+
+; Ranking
+
+; Votes divided by the age in hours to the gravityth power.
+; Would be interesting to scale gravity in a slider.
+
+(= gravity* 1.8 timebase* 120 front-threshold* 1 
+   nourl-factor* .4 lightweight-factor* .3 )
+
+(def frontpage-rank (s (o scorefn realscore) (o gravity gravity*))
+  (* (/ (let base (- (scorefn s) 1)
+          (if (> base 0) (expt base .8) base))
+        (expt (/ (+ (item-age s) timebase*) 60) gravity))
+     (if (no (in s!type 'story 'poll))  .5
+         (blank s!url)                  nourl-factor*
+         (lightweight s)                (min lightweight-factor* 
+                                             (contro-factor s))
+                                        (contro-factor s))))
+
+(def contro-factor (s)
+  (aif (check (visible-family nil s) [> _ 20])
+       (min 1 (expt (/ (realscore s) it) 2))
+       1))
+
+(def realscore (i) (- i!score i!sockvotes))
+
+(disktable lightweights* (+ newsdir* "lightweights"))
+
+(def lightweight (s)
+  (or s!dead
+      (mem 'rally s!keys)  ; title is a rallying cry
+      (mem 'image s!keys)  ; post is mainly image(s)
+      (lightweights* (sitename s!url))
+      (lightweight-url s!url)))
+
+(defmemo lightweight-url (url)
+  (in (downcase (last (tokens url #\.))) "png" "jpg" "jpeg"))
+
+(def item-age (i) (minutes-since i!time))
+
+(def user-age (u) (minutes-since (uvar u created)))
+
+; Only looks at the 1000 most recent stories, which might one day be a 
+; problem if there is massive spam. 
+
+(def gen-topstories ()
+  (= ranked-stories* (rank-stories 180 1000 (memo frontpage-rank))))
+
+(def save-topstories ()
+  (writefile (map !id (firstn 180 ranked-stories*))
+             (+ newsdir* "topstories")))
+ 
+(def rank-stories (n consider scorefn)
+  (bestn n (compare > scorefn) (latest-items metastory nil consider)))
+
+; With virtual lists the above call to latest-items could be simply:
+; (map item (retrieve consider metastory:item (gen maxid* [- _ 1])))
+
+(def latest-items (test (o stop) (o n))
+  (accum a
+    (catch 
+      (down id maxid* 1
+        (let i (item id)
+          (if (or (and stop (stop i)) (and n (<= n 0))) 
+              (throw))
+          (when (test i) 
+            (a i) 
+            (if n (-- n))))))))
+             
+; redefined later
+
+(def metastory (i) (and i (in i!type 'story 'poll)))
+
+(def adjust-rank (s (o scorefn frontpage-rank))
+  (insortnew (compare > (memo scorefn)) s ranked-stories*)
+  (save-topstories))
+
+; If something rose high then stopped getting votes, its score would
+; decline but it would stay near the top.  Newly inserted stories would
+; thus get stuck in front of it. I avoid this by regularly adjusting 
+; the rank of a random top story.
+
+(defbg rerank-random 30 (rerank-random))
+
+(def rerank-random ()
+  (when ranked-stories*
+    (adjust-rank (ranked-stories* (rand (min 50 (len ranked-stories*)))))))
+
+(def topstories (user n (o threshold front-threshold*))
+  (retrieve n 
+            [and (>= (realscore _) threshold) (cansee user _)]
+            ranked-stories*))
+
+(= max-delay* 10)
+
+(def cansee (user i)
+  (if i!deleted   (admin user)
+      i!dead      (or (author user i) (seesdead user))
+      (delayed i) (author user i)
+      t))
+
+(let mature (table)
+  (def delayed (i)
+    (and (no (mature i!id))
+         (acomment i)
+         (or (< (item-age i) (min max-delay* (uvar i!by delay)))
+             (do (set (mature i!id))
+                 nil)))))
+
+(def seesdead (user)
+  (or (and user (uvar user showdead) (no (ignored user)))
+      (editor user)))
+
+(def visible (user is)
+  (keep [cansee user _] is))
+
+(def cansee-descendant (user c)
+  (or (cansee user c)
+      (some [cansee-descendant user (item _)] 
+            c!kids)))
+  
+(def editor (u) 
+  (and u (or (admin u) (> (uvar u auth) 0))))
+
+(def member (u) 
+  (and u (or (admin u) (uvar u member))))
+
+
+; Page Layout
+
+(= up-url* "grayarrow.gif" down-url* "graydown.gif" logo-url* "arc.png")
+
+(defopr favicon.ico req favicon-url*)
+
+; redefined later
+
+(def gen-css-url ()
+  (prn "<link rel=\"stylesheet\" type=\"text/css\" href=\"news.css\">"))
+
+(mac npage (title . body)
+  `(tag html 
+     (tag head 
+       (gen-css-url)
+       (prn "<link rel=\"shortcut icon\" href=\"" favicon-url* "\">")
+       (tag script (pr votejs*))
+       (tag title (pr ,title)))
+     (tag body 
+       (center
+         (tag (table border 0 cellpadding 0 cellspacing 0 width "85%"
+                     bgcolor sand)
+           ,@body)))))
+
+(= pagefns* nil)
+
+(mac fulltop (user lid label title whence . body)
+  (w/uniq (gu gi gl gt gw)
+    `(with (,gu ,user ,gi ,lid ,gl ,label ,gt ,title ,gw ,whence)
+       (npage (+ this-site* (if ,gt (+ bar* ,gt) ""))
+         (if (check-procrast ,gu)
+             (do (pagetop 'full ,gi ,gl ,gt ,gu ,gw)
+                 (hook 'page ,gu ,gl)
+                 ,@body)
+             (row (procrast-msg ,gu ,gw)))))))
+
+(mac longpage (user t1 lid label title whence . body)
+  (w/uniq (gu gt gi)
+    `(with (,gu ,user ,gt ,t1 ,gi ,lid)
+       (fulltop ,gu ,gi ,label ,title ,whence
+         (trtd ,@body)
+         (trtd (vspace 10)
+               (color-stripe (main-color ,gu))
+               (br)
+               (center
+                 (hook 'longfoot)
+                 (admin-bar ,gu (- (msec) ,gt) ,whence)))))))
+
+(def admin-bar (user elapsed whence)
+  (when (admin user)
+    (br2)
+    (w/bars
+      (pr (len items*) "/" maxid* " loaded")
+      (pr (round (/ (memory) 1000000)) " mb")
+      (pr elapsed " msec")
+      (link "settings" "newsadmin")
+      (hook 'admin-bar user whence))))
+
+(def color-stripe (c)
+  (tag (table width "100%" cellspacing 0 cellpadding 1)
+    (tr (tdcolor c))))
+
+(mac shortpage (user lid label title whence . body)
+  `(fulltop ,user ,lid ,label ,title ,whence 
+     (trtd ,@body)))
+
+(mac minipage (label . body)
+  `(npage (+ this-site* bar* ,label)
+     (pagetop nil nil ,label)
+     (trtd ,@body)))
+
+(def msgpage (user msg (o title))
+  (minipage (or title "Message")
+    (spanclass admin
+      (center (if (len> msg 80) 
+                  (widtable 500 msg)
+                  (pr msg))))
+    (br2)))
+
+(= (max-age* 'news.css) 86400)   ; cache css in browser for 1 day
+
+; turn off server caching via (= caching* 0) or won't see changes
+
+(defop news.css req
+  (pr "
+body  { font-family:Verdana; font-size:10pt; color:#828282; }
+td    { font-family:Verdana; font-size:10pt; color:#828282; }
+
+.admin td   { font-family:Verdana; font-size:8.5pt; color:#000000; }
+.subtext td { font-family:Verdana; font-size:  7pt; color:#828282; }
+
+input    { font-family:Courier; font-size:10pt; color:#000000; }
+input[type=\"submit\"] { font-family:Verdana; }
+textarea { font-family:Courier; font-size:10pt; color:#000000; }
+
+a:link    { color:#000000; text-decoration:none; } 
+a:visited { color:#828282; text-decoration:none; }
+
+.default { font-family:Verdana; font-size: 10pt; color:#828282; }
+.admin   { font-family:Verdana; font-size:8.5pt; color:#000000; }
+.title   { font-family:Verdana; font-size: 10pt; color:#828282; }
+.adtitle { font-family:Verdana; font-size:  9pt; color:#828282; }
+.subtext { font-family:Verdana; font-size:  7pt; color:#828282; }
+.yclinks { font-family:Verdana; font-size:  8pt; color:#828282; }
+.pagetop { font-family:Verdana; font-size: 10pt; color:#222222; }
+.comhead { font-family:Verdana; font-size:  8pt; color:#828282; }
+.comment { font-family:Verdana; font-size:  9pt; }
+.dead    { font-family:Verdana; font-size:  9pt; color:#dddddd; }
+
+.comment a:link, .comment a:visited { text-decoration:underline;}
+.dead a:link, .dead a:visited { color:#dddddd; }
+.pagetop a:visited { color:#000000;}
+.topsel a:link, .topsel a:visited { color:#ffffff; }
+
+.subtext a:link, .subtext a:visited { color:#828282; }
+.subtext a:hover { text-decoration:underline; }
+
+.comhead a:link, .subtext a:visited { color:#828282; }
+.comhead a:hover { text-decoration:underline; }
+
+.default p { margin-top: 8px; margin-bottom: 0px; }
+
+.pagebreak {page-break-before:always}
+
+pre { overflow: auto; padding: 2px; max-width:600px; }
+pre:hover {overflow:auto} "))
+
+; only need pre padding because of a bug in Mac Firefox
+
+; Without setting the bottom margin of p tags to 0, 1- and n-para comments
+; have different space at the bottom.  This solution suggested by Devin.
+; Really am using p tags wrong (as separators rather than wrappers) and the
+; correct thing to do would be to wrap each para in <p></p>.  Then whatever
+; I set the bottom spacing to, it would be the same no matter how many paras
+; in a comment. In this case by setting the bottom spacing of p to 0, I'm
+; making it the same as no p, which is what the first para has.
+
+; supplied by pb
+;.vote { padding-left:2px; vertical-align:top; }
+;.comment { margin-top:1ex; margin-bottom:1ex; color:black; }
+;.vote IMG { border:0; margin: 3px 2px 3px 2px; }
+;.reply { font-size:smaller; text-decoration:underline !important; }
+
+(= votejs* "
+function byId(id) {
+  return document.getElementById(id);
+}
+
+function vote(node) {
+  var v = node.id.split(/_/);   // {'up', '123'}
+  var item = v[1]; 
+
+  // adjust score
+  var score = byId('score_' + item);
+  var newscore = parseInt(score.innerHTML) + (v[0] == 'up' ? 1 : -1);
+  score.innerHTML = newscore + (newscore == 1 ? ' point' : ' points');
+
+  // hide arrows
+  byId('up_'   + item).style.visibility = 'hidden';
+  byId('down_' + item).style.visibility = 'hidden';
+
+  // ping server
+  var ping = new Image();
+  ping.src = node.href;
+
+  return false; // cancel browser nav
+} ")
+
+
+; Page top
+
+(= sand (color 246 246 239) textgray (gray 130))
+
+(def main-color (user) 
+  (aif (and user (uvar user topcolor))
+       (hex>color it)
+       site-color*))
+
+(def pagetop (switch lid label (o title) (o user) (o whence))
+; (tr (tdcolor black (vspace 5)))
+  (tr (tdcolor (main-color user)
+        (tag (table border 0 cellpadding 0 cellspacing 0 width "100%"
+                    style "padding:2px")
+          (tr (gen-logo)
+              (when (is switch 'full)
+                (tag (td style "line-height:12pt; height:10px;")
+                  (spanclass pagetop
+                    (tag b (link this-site* "news"))
+                    (hspace 10)
+                    (toprow user label))))
+             (if (is switch 'full)
+                 (tag (td style "text-align:right;padding-right:4px;")
+                   (spanclass pagetop (topright user whence)))
+                 (tag (td style "line-height:12pt; height:10px;")
+                   (spanclass pagetop (prbold label))))))))
+  (map [_ user] pagefns*)
+  (spacerow 10))
+
+(def gen-logo ()
+  (tag (td style "width:18px;padding-right:4px")
+    (tag (a href parent-url*)
+      (tag (img src logo-url* width 18 height 18 
+                style "border:1px #@(hexrep border-color*) solid;")))))
+
+(= toplabels* '(nil "welcome" "new" "threads" "comments" "leaders" "*"))
+
+; redefined later
+
+(= welcome-url* "welcome")
+
+(def toprow (user label)
+  (w/bars 
+    (when (noob user)
+      (toplink "welcome" welcome-url* label)) 
+    (toplink "new" "newest" label)
+    (when user
+      (toplink "threads" (threads-url user) label))
+    (toplink "comments" "newcomments" label)
+    (toplink "leaders"  "leaders"     label)
+    (hook 'toprow user label)
+    (link "submit")
+    (unless (mem label toplabels*)
+      (fontcolor white (pr label)))))
+
+(def toplink (name dest label)
+  (tag-if (is name label) (span class 'topsel)
+    (link name dest)))
+
+(def topright (user whence (o showkarma t))
+  (when user 
+    (userlink user user nil)
+    (when showkarma (pr  "&nbsp;(@(karma user))"))
+    (pr "&nbsp;|&nbsp;"))
+  (if user
+      (rlinkf 'logout (req)
+        (when-umatch/r user req
+          (logout-user user)
+          whence))
+      (onlink "login"
+        (login-page 'both nil 
+                    (list (fn (u ip) 
+                            (ensure-news-user u)
+                            (newslog ip u 'top-login))
+                          whence)))))
+
+(def noob (user)
+  (and user (< (days-since (uvar user created)) 1)))
+
+
+; News-Specific Defop Variants
+
+(mac defopt (name parm test msg . body)
+  `(defop ,name ,parm
+     (if (,test (get-user ,parm))
+         (do ,@body)
+         (login-page 'both (+ "Please log in" ,msg ".")
+                     (list (fn (u ip) (ensure-news-user u))
+                           (string ',name (reassemble-args ,parm)))))))
+
+(mac defopg (name parm . body)
+  `(defopt ,name ,parm idfn "" ,@body))
+
+(mac defope (name parm . body)
+  `(defopt ,name ,parm editor " as an editor" ,@body))
+
+(mac defopa (name parm . body)
+  `(defopt ,name ,parm admin " as an administrator" ,@body))
+
+(mac opexpand (definer name parms . body)
+  (w/uniq gr
+    `(,definer ,name ,gr
+       (with (user (get-user ,gr) ip (,gr 'ip))
+         (with ,(and parms (mappend [list _ (list 'arg gr (string _))]
+                                    parms))
+           (newslog ip user ',name ,@parms)
+           ,@body)))))
+
+(= newsop-names* nil)
+
+(mac newsop args
+  `(do (pushnew ',(car args) newsop-names*)
+       (opexpand defop ,@args)))
+
+(mac adop (name parms . body)
+  (w/uniq g
+    `(opexpand defopa ,name ,parms 
+       (let ,g (string ',name)
+         (shortpage user nil ,g ,g ,g
+           ,@body)))))
+
+(mac edop (name parms . body)
+  (w/uniq g
+    `(opexpand defope ,name ,parms 
+       (let ,g (string ',name)
+         (shortpage user nil ,g ,g ,g
+           ,@body)))))
+
+
+; News Admin
+
+(defopa newsadmin req 
+  (let user (get-user req)
+    (newslog req!ip user 'newsadmin)
+    (newsadmin-page user)))
+
+; Note that caching* is reset to val in source when restart server.
+
+(def nad-fields ()
+  `((num      caching         ,caching*                       t t)
+    (bigtoks  comment-kill    ,comment-kill*                  t t)
+    (bigtoks  comment-ignore  ,comment-ignore*                t t)
+    (bigtoks  lightweights    ,(sort < (keys lightweights*))  t t)))
+
+; Need a util like vars-form for a collection of variables.
+; Or could generalize vars-form to think of places (in the setf sense).
+
+(def newsadmin-page (user)
+  (shortpage user nil nil "newsadmin" "newsadmin"
+    (vars-form user 
+               (nad-fields)
+               (fn (name val)
+                 (case name
+                   caching            (= caching* val)
+                   comment-kill       (todisk comment-kill* val)
+                   comment-ignore     (todisk comment-ignore* val)
+                   lightweights       (todisk lightweights* (memtable val))
+                   ))
+               (fn () (newsadmin-page user))) 
+    (br2)
+    (aform (fn (req)
+             (with (user (get-user req) subject (arg req "id"))
+               (if (profile subject)
+                   (do (killallby subject)
+                       (submitted-page user subject))
+                   (admin&newsadmin-page user))))
+      (single-input "" 'id 20 "kill all by"))
+    (br2)
+    (aform (fn (req)
+             (let user (get-user req)
+               (set-ip-ban user (arg req "ip") t)
+               (admin&newsadmin-page user)))
+      (single-input "" 'ip 20 "ban ip"))))
+
+
+; Users
+
+(newsop user (id)
+  (if (only.profile id)
+      (user-page user id)
+      (pr "No such user.")))
+
+(def user-page (user subject)
+  (let here (user-url subject)
+    (shortpage user nil nil (+ "Profile: " subject) here
+      (profile-form user subject)
+      (br2)
+      (when (some astory:item (uvar subject submitted))
+        (underlink "submissions" (submitted-url subject)))
+      (when (some acomment:item (uvar subject submitted))
+        (sp)
+        (underlink "comments" (threads-url subject)))
+      (hook 'user user subject))))
+
+(def profile-form (user subject)
+  (let prof (profile subject) 
+    (vars-form user
+               (user-fields user subject)
+               (fn (name val) 
+                 (when (and (is name 'ignore) val (no prof!ignore))
+                   (log-ignore user subject 'profile))
+                 (= (prof name) val))
+               (fn () (save-prof subject)
+                      (user-page user subject)))))
+
+(= topcolor-threshold* 250)
+
+(def user-fields (user subject)
+  (withs (e (editor user) 
+          a (admin user) 
+          w (is user subject)
+          k (and w (> (karma user) topcolor-threshold*))
+          u (or a w)
+          m (or a (and (member user) w))
+          p (profile subject))
+    `((string  user       ,subject                                  t   nil)
+      (string  name       ,(p 'name)                               ,m  ,m)
+      (string  created    ,(text-age:user-age subject)              t   nil)
+      (string  password   ,(resetpw-link)                          ,w   nil)
+      (string  saved      ,(saved-link user subject)               ,u   nil)
+      (int     auth       ,(p 'auth)                               ,e  ,a)
+      (yesno   member     ,(p 'member)                             ,a  ,a)
+      (posint  karma      ,(p 'karma)                               t  ,a)
+      (num     avg        ,(p 'avg)                                ,a  nil)
+      (yesno   ignore     ,(p 'ignore)                             ,e  ,e)
+      (num     weight     ,(p 'weight)                             ,a  ,a)
+      (mdtext2 about      ,(p 'about)                               t  ,u)
+      (string  email      ,(p 'email)                              ,u  ,u)
+      (yesno   showdead   ,(p 'showdead)                           ,u  ,u)
+      (yesno   noprocrast ,(p 'noprocrast)                         ,u  ,u)
+      (string  firstview  ,(p 'firstview)                          ,a   nil)
+      (string  lastview   ,(p 'lastview)                           ,a   nil)
+      (posint  maxvisit   ,(p 'maxvisit)                           ,u  ,u)
+      (posint  minaway    ,(p 'minaway)                            ,u  ,u)
+      (sexpr   keys       ,(p 'keys)                               ,a  ,a)
+      (hexcol  topcolor   ,(or (p 'topcolor) (hexrep site-color*)) ,k  ,k)
+      (int     delay      ,(p 'delay)                              ,u  ,u))))
+
+(def saved-link (user subject)
+  (when (or (admin user) (is user subject))
+    (let n (if (len> (votes subject) 500) 
+               "many" 
+               (len (voted-stories user subject)))
+      (if (is n 0)
+          ""
+          (tostring (underlink n (saved-url subject)))))))
+
+(def resetpw-link ()
+  (tostring (underlink "reset password" "resetpw")))
+
+(newsop welcome ()
+  (pr "Welcome to " this-site* ", " user "!"))
+
+
+; Main Operators
+
+; remember to set caching to 0 when testing non-logged-in 
+
+(= caching* 1 perpage* 30 threads-perpage* 10 maxend* 210)
+
+; Limiting that newscache can't take any arguments except the user.
+; To allow other arguments, would have to turn the cache from a single 
+; stored value to a hash table whose keys were lists of arguments.
+
+(mac newscache (name user time . body)
+  (w/uniq gc
+    `(let ,gc (cache (fn () (* caching* ,time))
+                     (fn () (tostring (let ,user nil ,@body))))
+       (def ,name (,user) 
+         (if ,user 
+             (do ,@body) 
+             (pr (,gc)))))))
+
+
+(newsop news () (newspage user))
+
+(newsop ||   () (newspage user))
+
+;(newsop index.html () (newspage user))
+
+(newscache newspage user 90
+  (listpage user (msec) (topstories user maxend*) nil nil "news"))
+
+(def listpage (user t1 items label title (o url label) (o number t))
+  (hook 'listpage user)
+  (longpage user t1 nil label title url
+    (display-items user items label title url 0 perpage* number)))
+
+
+(newsop newest () (newestpage user))
+
+; Note: dead/deleted items will persist for the remaining life of the 
+; cached page.  If this were a prob, could make deletion clear caches.
+
+(newscache newestpage user 40
+  (listpage user (msec) (newstories user maxend*) "new" "New Links" "newest"))
+
+(def newstories (user n)
+  (retrieve n [cansee user _] stories*))
+
+
+(newsop best () (bestpage user))
+
+(newscache bestpage user 1000
+  (listpage user (msec) (beststories user maxend*) "best" "Top Links"))
+
+; As no of stories gets huge, could test visibility in fn sent to best.
+
+(def beststories (user n)
+  (bestn n (compare > realscore) (visible user stories*)))
+
+
+(newsop noobstories () (noobspage user stories*))
+(newsop noobcomments () (noobspage user comments*))
+
+(def noobspage (user source)
+  (listpage user (msec) (noobs user maxend* source) "noobs" "New Accounts"))
+
+(def noobs (user n source)
+  (retrieve n [and (cansee user _) (bynoob _)] source))
+
+(def bynoob (i)
+  (< (- (user-age i!by) (item-age i)) 2880))
+
+
+(newsop bestcomments () (bestcpage user))
+
+(newscache bestcpage user 1000
+  (listpage user (msec) (bestcomments user maxend*) 
+            "best comments" "Best Comments" "bestcomments" nil))
+
+(def bestcomments (user n)
+  (bestn n (compare > realscore) (visible user comments*)))
+
+
+(newsop lists () 
+  (longpage user (msec) nil "lists" "Lists" "lists"
+    (sptab
+      (row (link "best")         "Highest voted recent links.")
+      (row (link "active")       "Most active current discussions.")
+      (row (link "bestcomments") "Highest voted recent comments.")
+      (row (link "noobstories")  "Submissions from new accounts.")
+      (row (link "noobcomments") "Comments from new accounts.")
+      (when (admin user)
+        (map row:link
+             '(optimes topips flagged killed badguys badlogins goodlogins)))
+      (hook 'listspage user))))
+
+
+(def saved-url (user) (+ "saved?id=" user))
+
+(newsop saved (id) 
+  (if (only.profile id)
+      (savedpage user id) 
+      (pr "No such user.")))
+
+(def savedpage (user subject)
+  (if (or (is user subject) (admin user))
+      (listpage user (msec)
+                (sort (compare < item-age) (voted-stories user subject)) 
+               "saved" "Saved Links" (saved-url subject))
+      (pr "Can't display that.")))
+
+(def voted-stories (user subject)
+  (keep [and (astory _) (cansee user _)]
+        (map item (keys:votes subject))))
+
+
+; Story Display
+
+(def display-items (user items label title whence 
+                    (o start 0) (o end perpage*) (o number))
+  (zerotable
+    (let n start
+      (each i (cut items start end)
+        (display-item (and number (++ n)) i user whence t)
+        (spacerow (if (acomment i) 15 5))))
+    (when end
+      (let newend (+ end perpage*)
+        (when (and (<= newend maxend*) (< end (len items)))
+          (spacerow 10)
+          (tr (tag (td colspan (if number 2 1)))
+              (tag (td class 'title)
+                (morelink display-items 
+                          items label title end newend number))))))))
+
+; This code is inevitably complex because the More fn needs to know 
+; its own fnid in order to supply a correct whence arg to stuff on 
+; the page it generates, like logout and delete links.
+
+(def morelink (f items label title . args)
+  (tag (a href 
+          (url-for
+            (afnid (fn (req)
+                     (prn)
+                     (with (url  (url-for it)     ; it bound by afnid
+                            user (get-user req))
+                       (newslog req!ip user 'more label)
+                       (longpage user (msec) nil label title url
+                         (apply f user items label title url args))))))
+          rel 'nofollow)
+    (pr "More")))
+
+(def display-story (i s user whence)
+  (when (or (cansee user s) (s 'kids))
+    (tr (display-item-number i)
+        (td (votelinks s user whence))
+        (titleline s s!url user whence))
+    (tr (tag (td colspan (if i 2 1)))    
+        (tag (td class 'subtext)
+          (hook 'itemline s user)
+          (itemline s user)
+          (when (in s!type 'story 'poll) (commentlink s user))
+          (editlink s user)
+          (when (apoll s) (addoptlink s user))
+          (unless i (flaglink s user whence))
+          (killlink s user whence)
+          (blastlink s user whence)
+          (blastlink s user whence t)
+          (deletelink s user whence)))))
+
+(def display-item-number (i)
+  (when i (tag (td align 'right valign 'top class 'title)
+            (pr i "."))))
+
+(= follow-threshold* 5)
+
+(def titleline (s url user whence)
+  (tag (td class 'title)
+    (if (cansee user s)
+        (do (deadmark s user)
+            (titlelink s url user)
+            (pdflink url)
+            (awhen (sitename url)
+              (spanclass comhead
+                (pr " (" )
+                (if (admin user)
+                    (w/rlink (do (set-site-ban user
+                                               it
+                                               (case (car (banned-sites* it))
+                                                 nil    'ignore
+                                                 ignore 'kill
+                                                 kill   nil))
+                                 whence)
+                      (let ban (car (banned-sites* it))
+                        (tag-if ban (font color (case ban 
+                                                  ignore darkred 
+                                                  kill   darkblue))
+                          (pr it))))
+                    (pr it))
+                (pr ") "))))
+        (pr (pseudo-text s)))))
+
+(def titlelink (s url user)
+  (let toself (blank url)
+    (tag (a href (if toself 
+                      (item-url s!id) 
+                     (or (live s) (author user s) (editor user))
+                      url
+                      nil)
+            rel  (unless (or toself (> (realscore s) follow-threshold*))
+                   'nofollow)) 
+      (pr s!title))))
+
+(def pdflink (url)
+  (awhen (vacuumize url)
+    (pr " [") 
+    (link "scribd" it)
+    (pr "]")))
+
+(defmemo vacuumize (url)
+  (and (or (endmatch ".pdf" url) (endmatch ".PDF" url))
+       (+ "http://www.scribd.com/vacuum?url=" url)))
+      
+(def pseudo-text (i)
+  (if i!deleted "[deleted]" "[dead]"))
+
+(def deadmark (i user)
+  (when (and i!dead (seesdead user))
+    (pr " [dead] "))
+  (when (and i!deleted (admin user))
+    (pr " [deleted] ")))
+
+(= downvote-threshold* 200 downvote-time* 1440)
+
+(= votewid* 14)
+      
+(def votelinks (i user whence (o downtoo))
+  (center
+    (if (and (cansee user i)
+             (or (no user)
+                 (no ((votes user) i!id))))
+         (do (votelink i user whence 'up)
+             (if (and downtoo 
+                      (or (admin user)
+                          (< (item-age i) downvote-time*))
+                      (canvote user i 'down))
+                 (do (br)
+                     (votelink i user whence 'down))
+                 ; don't understand why needed, but is, or a new
+                 ; page is generated on voting
+                 (tag (span id (+ "down_" i!id)))))
+        (author user i)
+         (do (fontcolor orange (pr "*"))
+             (br)
+             (hspace votewid*))
+        (hspace votewid*))))
+
+; could memoize votelink more, esp for non-logged in users,
+; since only uparrow is shown; could straight memoize
+
+; redefined later (identically) so the outs catch new vals of up-url, etc.
+
+(def votelink (i user whence dir)
+  (tag (a id      (if user (string dir '_ i!id))
+          onclick (if user "return vote(this)")
+          href    (vote-url user i dir whence))
+    (if (is dir 'up)
+        (out (gentag img src up-url*   border 0 vspace 3 hspace 2))
+        (out (gentag img src down-url* border 0 vspace 3 hspace 2)))))
+
+(def vote-url (user i dir whence)
+  (+ "vote?" "for=" i!id
+             "&dir=" dir
+             (if user (+ "&by=" user "&auth=" (user->cookie* user)))
+             "&whence=" (urlencode whence)))
+
+(= lowest-score* -4)
+
+; Not much stricter than whether to generate the arrow.  Further tests 
+; applied in vote-for.
+
+(def canvote (user i dir)
+  (and user
+       (news-type&live i)
+       (or (is dir 'up) (> i!score lowest-score*))
+       (no ((votes user) i!id))
+       (or (is dir 'up)
+           (and (acomment i)
+                (> (karma user) downvote-threshold*)
+                (no (aand i!parent (author user (item it))))))))
+
+; Need the by argument or someone could trick logged in users into 
+; voting something up by clicking on a link.  But a bad guy doesn't 
+; know how to generate an auth arg that matches each user's cookie.
+
+(newsop vote (by for dir auth whence)
+  (with (i      (safe-item for)
+         dir    (saferead dir)
+         whence (if whence (urldecode whence) "news"))
+    (if (no i)
+         (pr "No such item.")
+        (no (in dir 'up 'down))
+         (pr "Can't make that vote.")
+        (and by (or (isnt by user) (isnt (sym auth) (user->cookie* user))))
+         (pr "User mismatch.")
+        (no user)
+         (login-page 'both "You have to be logged in to vote."
+                     (list (fn (u ip)
+                             (ensure-news-user u)
+                             (newslog ip u 'vote-login)
+                             (when (canvote u i dir)
+                               (vote-for u i dir)
+                               (logvote ip u i)))
+                           whence))
+        (canvote user i dir)
+         (do (vote-for by i dir)
+             (logvote ip by i))
+         (pr "Can't make that vote."))))
+
+(def itemline (i user)
+  (when (cansee user i) 
+    (when (news-type i) (itemscore i user))
+    (byline i user)))
+
+(def itemscore (i (o user))
+  (tag (span id (+ "score_" i!id))
+    (pr (plural (if (is i!type 'pollopt) (realscore i) i!score)
+                "point")))
+  (hook 'itemscore i user))
+
+; redefined later
+
+(def byline (i user)
+  (pr " by @(tostring (userlink user i!by)) @(text-age:item-age i) "))
+
+(def user-url (user) (+ "user?id=" user))
+
+(= show-avg* nil)
+
+(def userlink (user subject (o show-avg t))
+  (link (user-name user subject) (user-url subject))
+  (awhen (and show-avg* (admin user) show-avg (uvar subject avg))
+    (pr " (@(num it 1 t t))")))
+
+(= noob-color* (color 60 150 60))
+
+(def user-name (user subject)
+  (if (and (editor user) (ignored subject))
+       (tostring (fontcolor darkred (pr subject)))
+      (and (editor user) (< (user-age subject) 1440))
+       (tostring (fontcolor noob-color* (pr subject)))
+      subject))
+
+(= show-threadavg* nil)
+
+(def commentlink (i user)
+  (when (cansee user i) 
+    (pr bar*)
+    (tag (a href (item-url i!id))
+      (let n (- (visible-family user i) 1)
+        (if (> n 0)
+            (do (pr (plural n "comment"))
+                (awhen (and show-threadavg* (admin user) (threadavg i))
+                  (pr " (@(num it 1 t t))")))
+            (pr "discuss"))))))
+
+(def visible-family (user i)
+  (+ (if (cansee user i) 1 0)
+     (sum [visible-family user (item _)] i!kids)))
+
+(def threadavg (i)
+  (only.avg (map [or (uvar _ avg) 1] 
+                 (rem admin (dedup (map !by (keep live (family i))))))))
+
+(= user-changetime* 120 editor-changetime* 1440)
+
+(= everchange* (table) noedit* (table))
+
+(def canedit (user i)
+  (or (admin user)
+      (and (~noedit* i!type)
+           (editor user) 
+           (< (item-age i) editor-changetime*))
+      (own-changeable-item user i)))
+
+(def own-changeable-item (user i)
+  (and (author user i)
+       (~mem 'locked i!keys)
+       (no i!deleted)
+       (or (everchange* i!type)
+           (< (item-age i) user-changetime*))))
+
+(def editlink (i user)
+  (when (canedit user i)
+    (pr bar*)
+    (link "edit" (edit-url i))))
+
+(def addoptlink (p user)
+  (when (or (admin user) (author user p))
+    (pr bar*)
+    (onlink "add choice" (add-pollopt-page p user))))
+
+; reset later
+
+(= flag-threshold* 30 flag-kill-threshold* 7 many-flags* 1)
+
+; Un-flagging something doesn't unkill it, if it's now no longer
+; over flag-kill-threshold.  Ok, since arbitrary threshold anyway.
+
+(def flaglink (i user whence)
+  (when (and user
+             (isnt user i!by)
+             (or (admin user) (> (karma user) flag-threshold*)))
+    (pr bar*)
+    (w/rlink (do (togglemem user i!flags)
+                 (when (and (~mem 'nokill i!keys)
+                            (len> i!flags flag-kill-threshold*)
+                            (< (realscore i) 10)
+                            (~find admin:!2 i!vote))
+                   (kill i 'flags))
+                 whence)
+      (pr "@(if (mem user i!flags) 'un)flag"))
+    (when (and (admin user) (len> i!flags many-flags*))
+      (pr bar* (plural (len i!flags) "flag") " ")
+      (w/rlink (do (togglemem 'nokill i!keys)
+                   (save-item i)
+                   whence)
+        (pr (if (mem 'nokill i!keys) "un-notice" "noted"))))))
+
+(def killlink (i user whence)
+  (when (admin user)
+    (pr bar*)
+    (w/rlink (do (zap no i!dead)
+                 (if i!dead 
+                     (do (pull 'nokill i!keys)
+                         (log-kill i user))
+                     (pushnew 'nokill i!keys))
+                 (save-item i)
+                 whence)
+      (pr "@(if i!dead 'un)kill"))))
+
+; Blast kills the submission and bans the user.  Nuke also bans the 
+; site, so that all future submitters will be ignored.  Does not ban 
+; the ip address, but that will eventually get banned by maybe-ban-ip.
+
+(def blastlink (i user whence (o nuke))
+  (when (and (admin user) 
+             (or (no nuke) (~empty i!url)))
+    (pr bar*)
+    (w/rlink (do (toggle-blast i user nuke)
+                 whence)
+      (prt (if (ignored i!by) "un-") (if nuke "nuke" "blast")))))
+
+(def toggle-blast (i user (o nuke))
+  (atomic
+    (if (ignored i!by)
+        (do (wipe i!dead (ignored i!by))
+            (awhen (and nuke (sitename i!url))
+              (set-site-ban user it nil)))
+        (do (set i!dead)
+            (ignore user i!by (if nuke 'nuke 'blast))
+            (awhen (and nuke (sitename i!url))
+              (set-site-ban user it 'ignore))))
+    (if i!dead (log-kill i user))
+    (save-item i)
+    (save-prof i!by)))
+
+(def candelete (user i)
+  (or (admin user) (own-changeable-item user i)))
+
+(def deletelink (i user whence)
+  (when (candelete user i)
+    (pr bar*)
+    (linkf (if i!deleted "undelete" "delete") (req)
+      (let user (get-user req)
+        (if (candelete user i)
+            (del-confirm-page user i whence)
+            (prn "You can't delete that."))))))
+
+; Undeleting stories could cause a slight inconsistency. If a story
+; linking to x gets deleted, another submission can take its place in
+; url->story.  If the original is then undeleted, there will be two 
+; stories with equal claim to be in url->story.  (The more recent will
+; win because it happens to get loaded later.)  Not a big problem.
+
+(def del-confirm-page (user i whence)
+  (minipage "Confirm"
+    (tab 
+      ; link never used so not testable but think correct
+      (display-item nil i user (flink [del-confirm-page (get-user _) i whence]))
+      (spacerow 20)
+      (tr (td)
+          (td (urform user req
+                      (do (when (candelete user i)
+                            (= i!deleted (is (arg req "b") "Yes"))
+                            (save-item i))
+                          whence)
+                 (prn "Do you want this to @(if i!deleted 'stay 'be) deleted?")
+                 (br2)
+                 (but "Yes" "b") (sp) (but "No" "b")))))))
+
+(def permalink (story user)
+  (when (cansee user story)
+    (pr bar*) 
+    (link "link" (item-url story!id))))
+
+(def logvote (ip user story)
+  (newslog ip user 'vote (story 'id) (list (story 'title))))
+
+(def text-age (a)
+  (tostring
+    (if (>= a 1440) (pr (plural (trunc (/ a 1440)) "day")    " ago")
+        (>= a   60) (pr (plural (trunc (/ a 60))   "hour")   " ago")
+                    (pr (plural (trunc a)          "minute") " ago"))))
+
+
+; Voting
+
+; A user needs legit-threshold karma for a vote to count if there has 
+; already been a vote from the same IP address.  A new account below both
+; new- thresholds won't affect rankings, though such votes still affect 
+; scores unless not a legit-user.
+
+(= legit-threshold* 0 new-age-threshold* 0 new-karma-threshold* 2)
+
+(def legit-user (user) 
+  (or (editor user)
+      (> (karma user) legit-threshold*)))
+
+(def possible-sockpuppet (user)
+  (or (ignored user)
+      (< (uvar user weight) .5)
+      (and (< (user-age user) new-age-threshold*)
+           (< (karma user) new-karma-threshold*))))
+
+(= downvote-ratio-limit* .65 recent-votes* nil votewindow* 100)
+
+; Note: if vote-for by one user changes (s 'score) while s is being
+; edited by another, the save after the edit will overwrite the change.
+; Actual votes can't be lost because that field is not editable.  Not a
+; big enough problem to drag in locking.
+
+(def vote-for (user i (o dir 'up))
+  (unless (or ((votes user) i!id) 
+              (and (~live i) (isnt user i!by)))
+    (withs (ip   (logins* user)
+            vote (list (seconds) ip user dir i!score))
+      (unless (or (and (or (ignored user) (check-key user 'novote))
+                       (isnt user i!by))
+                  (and (is dir 'down)
+                       (~editor user)
+                       (or (check-key user 'nodowns)
+                           (> (downvote-ratio user) downvote-ratio-limit*)
+                           ; prevention of karma-bombing
+                           (just-downvoted user i!by)))
+                  (and (~legit-user user)
+                       (isnt user i!by)
+                       (find [is (cadr _) ip] i!votes))
+                  (and (isnt i!type 'pollopt)
+                       (biased-voter i vote)))
+        (++ i!score (case dir up 1 down -1))
+        ; canvote protects against sockpuppet downvote of comments 
+        (when (and (is dir 'up) (possible-sockpuppet user))
+          (++ i!sockvotes))
+        (metastory&adjust-rank i)
+        (unless (or (author user i)
+                    (and (is ip i!ip) (~editor user))
+                    (is i!type 'pollopt))
+          (++ (karma i!by) (case dir up 1 down -1))
+          (save-prof i!by))
+        (wipe (comment-cache* i!id)))
+      (if (admin user) (pushnew 'nokill i!keys))
+      (push vote i!votes)
+      (save-item i)
+      (push (list (seconds) i!id i!by (sitename i!url) dir)
+            (uvar user votes))
+      (= ((votes* user) i!id) vote)
+      (save-votes user)
+      (zap [firstn votewindow* _] (uvar user votes))
+      (save-prof user)
+      (push (cons i!id vote) recent-votes*))))
+
+; redefined later
+
+(def biased-voter (i vote) nil)
+
+; ugly to access vote fields by position number
+
+(def downvote-ratio (user (o sample 20))
+  (ratio [is _.1.3 'down]
+         (keep [let by ((item (car _)) 'by)
+                 (nor (is by user) (ignored by))]
+               (bestn sample (compare > car:cadr) (tablist (votes user))))))
+
+(def just-downvoted (user victim (o n 3))
+  (let prev (firstn n (recent-votes-by user))
+    (and (is (len prev) n)
+         (all (fn ((id sec ip voter dir score))
+                (and (author victim (item id)) (is dir 'down)))
+              prev))))
+
+; Ugly to pluck out fourth element.  Should read votes into a vote
+; template.  They're stored slightly differently in two diff places: 
+; in one with the voter in the car and the other without.
+
+(def recent-votes-by (user)
+  (keep [is _.3 user] recent-votes*))
+
+
+; Story Submission
+
+(newsop submit ()
+  (if user 
+      (submit-page user "" "" t) 
+      (submit-login-warning "" "" t)))
+
+(def submit-login-warning ((o url) (o title) (o showtext) (o text))
+  (login-page 'both "You have to be logged in to submit."
+              (fn (user ip) 
+                (ensure-news-user user)
+                (newslog ip user 'submit-login)
+                (submit-page user url title showtext text))))
+
+(def submit-page (user (o url) (o title) (o showtext) (o text "") (o msg))
+  (minipage "Submit"
+    (pagemessage msg)
+    (urform user req
+            (process-story (get-user req)
+                           (clean-url (arg req "u"))
+                           (striptags (arg req "t"))
+                           showtext
+                           (and showtext (md-from-form (arg req "x") t))
+                           req!ip)
+      (tab
+        (row "title"  (input "t" title 50))
+        (if prefer-url*
+            (do (row "url" (input "u" url 50))
+                (when showtext
+                  (row "" "<b>or</b>")
+                  (row "text" (textarea "x" 4 50 (only.pr text)))))
+            (do (row "text" (textarea "x" 4 50 (only.pr text)))
+                (row "" "<b>or</b>")
+                (row "url" (input "u" url 50))))
+        (row "" (submit))
+        (spacerow 20)
+        (row "" submit-instructions*)))))
+
+(= submit-instructions*
+   "Leave url blank to submit a question for discussion. If there is 
+    no url, the text (if any) will appear at the top of the comments 
+    page. If there is a url, the text will be ignored.")
+
+; For use by outside code like bookmarklet.
+; http://news.domain.com/submitlink?u=http://foo.com&t=Foo
+; Added a confirm step to avoid xss hacks.
+
+(newsop submitlink (u t)
+  (if user 
+      (submit-page user u t)
+      (submit-login-warning u t)))
+
+(= title-limit* 80
+   retry*       "Please try again."
+   toolong*     "Please make title < @title-limit* characters."
+   bothblank*   "The url and text fields can't both be blank.  Please
+                 either supply a url, or if you're asking a question,
+                 put it in the text field."
+   toofast*     "You're submitting too fast.  Please slow down.  Thanks."
+   spammage*    "Stop spamming us.  You're wasting your time.")
+
+; Only for annoyingly high-volume spammers. For ordinary spammers it's
+; enough to ban their sites and ip addresses.
+
+(disktable big-spamsites* (+ newsdir* "big-spamsites"))
+
+(def process-story (user url title showtext text ip)
+  (aif (and (~blank url) (live-story-w/url url))
+       (do (vote-for user it)
+           (item-url it!id))
+       (if (no user)
+            (flink [submit-login-warning url title showtext text])
+           (no (and (or (blank url) (valid-url url)) 
+                    (~blank title)))
+            (flink [submit-page user url title showtext text retry*])
+           (len> title title-limit*)
+            (flink [submit-page user url title showtext text toolong*])
+           (and (blank url) (blank text))
+            (flink [submit-page user url title showtext text bothblank*])
+           (let site (sitename url)
+             (or (big-spamsites* site) (recent-spam site)))
+            (flink [msgpage user spammage*])
+           (oversubmitting user ip 'story url)
+            (flink [msgpage user toofast*])
+           (let s (create-story url (process-title title) text user ip)
+             (story-ban-test user s ip url)
+             (when (ignored user) (kill s 'ignored))
+             (submit-item user s)
+             (maybe-ban-ip s)
+             "newest"))))
+
+(def submit-item (user i)
+  (push i!id (uvar user submitted))
+  (save-prof user)
+  (vote-for user i))
+
+(def recent-spam (site)
+  (and (caris (banned-sites* site) 'ignore)
+       (recent-items [is (sitename _!url) site] 720)))
+
+(def recent-items (test minutes)
+  (let cutoff (- (seconds) (* 60 minutes))
+    (latest-items test [< _!time cutoff])))
+
+; Turn this on when spam becomes a problem.
+
+(= enforce-oversubmit* nil)
+
+; New user can't submit more than 2 stories in a 2 hour period.
+; Give overeager users the key toofast to make limit permanent.
+
+(def oversubmitting (user ip kind (o url))
+  (and enforce-oversubmit*
+       (or (check-key user 'toofast)
+           (ignored user)
+           (< (user-age user) new-age-threshold*)
+           (< (karma user) new-karma-threshold*))
+       (len> (recent-items [or (author user _) (is _!ip ip)] 180)
+             (if (is kind 'story)
+                 (if (bad-user user) 0 1)
+                 (if (bad-user user) 1 10)))))
+
+; Note that by deliberate tricks, someone could submit a story with a 
+; blank title.
+
+(diskvar scrubrules* (+ newsdir* "scrubrules"))
+
+(def process-title (s)
+  (let s2 (multisubst scrubrules* s)
+    (zap upcase (s2 0))
+    s2))
+
+(def live-story-w/url (url) 
+  (aand (url->story* (canonical-url url)) (check (item it) live)))
+
+(def parse-site (url)
+  (rev (tokens (cadr (tokens url [in _ #\/ #\?])) #\.)))
+
+(defmemo sitename (url)
+  (and (valid-url url)
+       (let toks (parse-site (rem #\space url))
+         (if (isa (saferead (car toks)) 'int)
+             (tostring (prall toks "" "."))
+             (let (t1 t2 t3 . rest) toks  
+               (if (and (~in t3 nil "www")
+                        (or (mem t1 multi-tld-countries*) 
+                            (mem t2 long-domains*)))
+                   (+ t3 "." t2 "." t1)
+                   (and t2 (+ t2 "." t1))))))))
+
+(= multi-tld-countries* '("uk" "jp" "au" "in" "ph" "tr" "za" "my" "nz" "br" 
+                          "mx" "th" "sg" "id" "pk" "eg" "il" "at" "pl"))
+
+(= long-domains* '("blogspot" "wordpress" "livejournal" "blogs" "typepad" 
+                   "weebly" "posterous" "blog-city" "supersized" "dreamhosters"
+                   ; "sampasite"  "multiply" "wetpaint" ; all spam, just ban
+                   "eurekster" "blogsome" "edogo" "blog" "com"))
+
+(def create-story (url title text user ip)
+  (newslog ip user 'create url (list title))
+  (let s (inst 'item 'type 'story 'id (new-item-id) 
+                     'url url 'title title 'text text 'by user 'ip ip)
+    (save-item s)
+    (= (items* s!id) s)
+    (unless (blank url) (register-url s url))
+    (push s stories*)
+    s))
+
+
+; Bans
+
+(def ignore (user subject cause)
+  (set (ignored subject))
+  (save-prof subject)
+  (log-ignore user subject cause))
+
+(diskvar ignore-log* (+ newsdir* "ignore-log"))
+
+(def log-ignore (user subject cause)
+  (todisk ignore-log* (cons (list subject user cause) ignore-log*)))
+
+; Kill means stuff with this substring gets killed. Ignore is stronger,
+; means that user will be auto-ignored.  Eventually this info should
+; be stored on disk and not in the source code.
+
+(disktable banned-ips*     (+ newsdir* "banned-ips"))   ; was ips
+(disktable banned-sites*   (+ newsdir* "banned-sites")) ; was sites
+
+(diskvar  comment-kill*    (+ newsdir* "comment-kill"))
+(diskvar  comment-ignore*  (+ newsdir* "comment-ignore"))
+
+(= comment-kill* nil ip-ban-threshold* 3)
+
+(def set-ip-ban (user ip yesno (o info))
+  (= (banned-ips* ip) (and yesno (list user (seconds) info)))
+  (todisk banned-ips*))
+
+(def set-site-ban (user site ban (o info))
+  (= (banned-sites* site) (and ban (list ban user (seconds) info)))
+  (todisk banned-sites*))
+
+; Kill submissions from banned ips, but don't auto-ignore users from
+; them, because eventually ips will become legit again.
+
+; Note that ban tests are only applied when a link or comment is
+; submitted, not each time it's edited.  This will do for now.
+
+(def story-ban-test (user i ip url)
+  (site-ban-test user i url)
+  (ip-ban-test i ip)
+  (hook 'story-ban-test user i ip url))
+
+(def site-ban-test (user i url)
+  (whenlet ban (banned-sites* (sitename url))
+    (if (caris ban 'ignore) (ignore nil user 'site-ban))
+    (kill i 'site-ban)))
+
+(def ip-ban-test (i ip)
+  (if (banned-ips* ip) (kill i 'banned-ip)))
+
+(def comment-ban-test (user i ip string kill-list ignore-list)
+  (when (some [posmatch _ string] ignore-list)
+    (ignore nil user 'comment-ban))
+  (when (or (banned-ips* ip) (some [posmatch _ string] kill-list))
+    (kill i 'comment-ban)))
+
+; An IP is banned when multiple ignored users have submitted over
+; ban-threshold* (currently loaded) dead stories from it.  
+
+; Can consider comments too if that later starts to be a problem,
+; but the threshold may start to be higher because then you'd be
+; dealing with trolls rather than spammers.
+
+(def maybe-ban-ip (s)
+  (when (and s!dead (ignored s!by))
+    (let bads (loaded-items [and _!dead (astory _) (is _!ip s!ip)])
+      (when (and (len> bads ip-ban-threshold*)
+                 (some [and (ignored _!by) (isnt _!by s!by)] bads))
+        (set-ip-ban nil s!ip t)))))
+
+(def killallby (user) 
+  (map [kill _ 'all] (submissions user)))
+
+; Only called from repl.
+
+(def kill-whole-thread (c)
+  (kill c 'thread)
+  (map kill-whole-thread:item c!kids))
+
+
+; Polls
+
+; a way to add a karma threshold for voting in a poll
+;  or better still an arbitrary test fn, or at least pair of name/threshold.
+; option to sort the elements of a poll when displaying
+; exclusive field? (means only allow one vote per poll)
+
+(= poll-threshold* 20)
+
+(newsop newpoll ()
+  (if (and user (> (karma user) poll-threshold*))
+      (newpoll-page user)
+      (pr "Sorry, you need @poll-threshold* karma to create a poll.")))
+  
+(def newpoll-page (user (o title "Poll: ") (o text "") (o opts "") (o msg))
+  (minipage "New Poll"
+    (pagemessage msg)
+    (urform user req
+            (process-poll (get-user req)
+                          (striptags (arg req "t"))
+                          (md-from-form (arg req "x") t)
+                          (striptags (arg req "o"))
+                          req!ip)
+      (tab   
+        (row "title"   (input "t" title 50))
+        (row "text"    (textarea "x" 4 50 (only.pr text)))
+        (row ""        "Use blank lines to separate choices:")
+        (row "choices" (textarea "o" 7 50 (only.pr opts)))
+        (row ""        (submit))))))
+
+(= fewopts* "A poll must have at least two options.")
+
+(def process-poll (user title text opts ip)
+  (if (or (blank title) (blank opts))
+       (flink [newpoll-page user title text opts retry*])
+      (len> title title-limit*)
+       (flink [newpoll-page user title text opts toolong*])
+      (len< (paras opts) 2)
+       (flink [newpoll-page user title text opts fewopts*])
+      (atlet p (create-poll (multisubst scrubrules* title) text opts user ip)
+        (ip-ban-test p ip)
+        (when (ignored user) (kill p 'ignored))
+        (submit-item user p)
+        (maybe-ban-ip p)
+        "newest")))
+
+(def create-poll (title text opts user ip)
+  (newslog ip user 'create-poll title)
+  (let p (inst 'item 'type 'poll 'id (new-item-id)
+                     'title title 'text text 'by user 'ip ip)
+    (= p!parts (map get!id (map [create-pollopt p nil nil _ user ip]
+                                (paras opts))))
+    (save-item p)
+    (= (items* p!id) p)
+    (push p stories*)
+    p))
+
+(def create-pollopt (p url title text user ip)
+  (let o (inst 'item 'type 'pollopt 'id (new-item-id)
+                     'url url 'title title 'text text 'parent p!id
+                     'by user 'ip ip)
+    (save-item o)
+    (= (items* o!id) o) 
+    o))
+
+(def add-pollopt-page (p user)
+  (minipage "Add Poll Choice"
+    (urform user req
+            (do (add-pollopt user p (striptags (arg req "x")) req!ip)
+                (item-url p!id))
+      (tab
+        (row "text" (textarea "x" 4 50))
+        (row ""     (submit))))))
+
+(def add-pollopt (user p text ip)
+  (unless (blank text)
+    (atlet o (create-pollopt p nil nil text user ip)
+      (++ p!parts (list o!id))
+      (save-item p))))
+
+(def display-pollopts (p user whence)
+  (each o (visible user (map item p!parts))
+    (display-pollopt nil o user whence)
+    (spacerow 7)))
+
+(def display-pollopt (n o user whence)
+  (tr (display-item-number n)
+      (tag (td valign 'top)
+        (votelinks o user whence))
+      (tag (td class 'comment)
+        (tag (div style "margin-top:1px;margin-bottom:0px")
+          (if (~cansee user o) (pr (pseudo-text o))
+              (~live o)        (spanclass dead 
+                                 (pr (if (~blank o!title) o!title o!text)))
+                               (if (and (~blank o!title) (~blank o!url))
+                                   (link o!title o!url)
+                                   (fontcolor black (pr o!text)))))))
+  (tr (if n (td))
+      (td)
+      (tag (td class 'default)
+        (spanclass comhead
+          (itemscore o)
+          (editlink o user)
+          (killlink o user whence)
+          (deletelink o user whence)
+          (deadmark o user)))))
+
+
+; Individual Item Page (= Comments Page of Stories)
+
+(defmemo item-url (id) (+ "item?id=" id))
+
+(newsop item (id)
+  (let s (safe-item id)
+    (if (news-type s)
+        (do (if s!deleted (note-baditem user ip))
+            (item-page user s))
+        (do (note-baditem user ip)
+            (pr "No such item.")))))
+
+(= baditemreqs* (table) baditem-threshold* 1/100)
+
+; Something looking at a lot of deleted items is probably the bad sort
+; of crawler.  Throttle it for this server invocation.
+
+(def note-baditem (user ip)
+  (unless (admin user)
+    (++ (baditemreqs* ip 0))
+    (with (r (requests/ip* ip) b (baditemreqs* ip))
+       (when (and (> r 500) (> (/ b r) baditem-threshold*))
+         (set (throttle-ips* ip))))))
+
+; redefined later
+
+(def news-type (i) (and i (in i!type 'story 'comment 'poll 'pollopt)))
+
+(def item-page (user i)
+  (with (title (and (cansee user i)
+                    (or i!title (aand i!text (ellipsize (striptags it)))))
+         here (item-url i!id))
+    (longpage user (msec) nil nil title here
+      (tab (display-item nil i user here)
+           (display-item-text i user)
+           (when (apoll i)
+             (spacerow 10)
+             (tr (td)
+                 (td (tab (display-pollopts i user here)))))
+           (when (and (cansee user i) (comments-active i))
+             (spacerow 10)
+             (row "" (comment-form i user here))))
+      (br2) 
+      (when (and i!kids (commentable i))
+        (tab (display-subcomments i user here))
+        (br2)))))
+
+(def commentable (i) (in i!type 'story 'comment 'poll))
+
+; By default the ability to comment on an item is turned off after 
+; 45 days, but this can be overriden with commentable key.
+
+(= commentable-threshold* (* 60 24 45))
+
+(def comments-active (i)
+  (and (live&commentable i)
+       (live (superparent i))
+       (or (< (item-age i) commentable-threshold*)
+           (mem 'commentable i!keys))))
+
+
+(= displayfn* (table))
+
+(= (displayfn* 'story)   (fn (n i user here inlist)
+                           (display-story n i user here)))
+
+(= (displayfn* 'comment) (fn (n i user here inlist)
+                           (display-comment n i user here nil 0 nil inlist)))
+
+(= (displayfn* 'poll)    (displayfn* 'story))
+
+(= (displayfn* 'pollopt) (fn (n i user here inlist)
+                           (display-pollopt n i user here)))
+
+(def display-item (n i user here (o inlist))
+  ((displayfn* (i 'type)) n i user here inlist))
+
+(def superparent (i)
+  (aif i!parent (superparent:item it) i))
+
+(def display-item-text (s user)
+  (when (and (cansee user s) 
+             (in s!type 'story 'poll)
+             (blank s!url) 
+             (~blank s!text))
+    (spacerow 2)
+    (row "" s!text)))
+
+
+; Edit Item
+
+(def edit-url (i) (+ "edit?id=" i!id))
+
+(newsop edit (id)
+  (let i (safe-item id)
+    (if (and i 
+             (cansee user i)
+             (editable-type i)
+             (or (news-type i) (admin user) (author user i)))
+        (edit-page user i)
+        (pr "No such item."))))
+
+(def editable-type (i) (fieldfn* i!type))
+
+(= fieldfn* (table))
+
+(= (fieldfn* 'story)
+   (fn (user s)
+     (with (a (admin user)  e (editor user)  x (canedit user s))
+       `((string1 title     ,s!title        t ,x)
+         (url     url       ,s!url          t ,e)
+         (mdtext2 text      ,s!text         t ,x)
+         ,@(standard-item-fields s a e x)))))
+
+(= (fieldfn* 'comment)
+   (fn (user c)
+     (with (a (admin user)  e (editor user)  x (canedit user c))
+       `((mdtext  text      ,c!text         t ,x)
+         ,@(standard-item-fields c a e x)))))
+
+(= (fieldfn* 'poll)
+   (fn (user p)
+     (with (a (admin user)  e (editor user)  x (canedit user p))
+       `((string1 title     ,p!title        t ,x)
+         (mdtext2 text      ,p!text         t ,x)
+         ,@(standard-item-fields p a e x)))))
+
+(= (fieldfn* 'pollopt)
+   (fn (user p)
+     (with (a (admin user)  e (editor user)  x (canedit user p))
+       `((string  title     ,p!title        t ,x)
+         (url     url       ,p!url          t ,x)
+         (mdtext2 text      ,p!text         t ,x)
+         ,@(standard-item-fields p a e x)))))
+
+(def standard-item-fields (i a e x)
+       `((int     votes     ,(len i!votes) ,a  nil)
+         (int     score     ,i!score        t ,a)
+         (int     sockvotes ,i!sockvotes   ,a ,a)
+         (yesno   dead      ,i!dead        ,e ,e)
+         (yesno   deleted   ,i!deleted     ,a ,a)
+         (sexpr   flags     ,i!flags       ,a nil)
+         (sexpr   keys      ,i!keys        ,a ,a)
+         (string  ip        ,i!ip          ,e  nil)))
+
+; Should check valid-url etc here too.  In fact make a fn that
+; does everything that has to happen after submitting a story,
+; and call it both there and here.
+
+(def edit-page (user i)
+  (let here (edit-url i)
+    (shortpage user nil nil "Edit" here
+      (tab (display-item nil i user here)
+           (display-item-text i user))
+      (br2)
+      (vars-form user
+                 ((fieldfn* i!type) user i)
+                 (fn (name val) 
+                   (unless (ignore-edit user i name val)
+                     (when (and (is name 'dead) val (no i!dead))
+                       (log-kill i user))
+                     (= (i name) val)))
+                 (fn () (if (admin user) (pushnew 'locked i!keys))
+                        (save-item i)
+                        (metastory&adjust-rank i)
+                        (wipe (comment-cache* i!id))
+                        (edit-page user i)))
+      (hook 'edit user i))))
+
+(def ignore-edit (user i name val)
+  (case name title (len> val title-limit*)
+             dead  (and (mem 'nokill i!keys) (~admin user))))
+
+ 
+; Comment Submission
+
+(def comment-login-warning (parent whence (o text))
+  (login-page 'both "You have to be logged in to comment."
+              (fn (u ip)
+                (ensure-news-user u)
+                (newslog ip u 'comment-login)
+                (addcomment-page parent u whence text))))
+
+(def addcomment-page (parent user whence (o text) (o msg))
+  (minipage "Add Comment"
+    (pagemessage msg)
+    (tab
+      (let here (flink [addcomment-page parent (get-user _) whence text msg])
+        (display-item nil parent user here))
+      (spacerow 10)
+      (row "" (comment-form parent user whence text)))))
+
+(= noob-comment-msg* nil)
+
+; Comment forms last for 30 min (- cache time)
+
+(def comment-form (parent user whence (o text))
+  (tarform 1800
+           (fn (req)
+             (when-umatch/r user req
+               (process-comment user parent (arg req "text") req!ip whence)))
+    (textarea "text" 6 60  
+      (aif text (prn (unmarkdown it))))
+    (when (and noob-comment-msg* (noob user))
+      (br2)
+      (spanclass subtext (pr noob-comment-msg*)))
+    (br2)
+    (submit (if (acomment parent) "reply" "add comment"))))
+
+(= comment-threshold* -20)
+
+; Have to remove #\returns because a form gives you back "a\r\nb"
+; instead of just "a\nb".   Maybe should just remove returns from
+; the vals coming in from any form, e.g. in aform.
+
+(def process-comment (user parent text ip whence)
+  (if (no user)
+       (flink [comment-login-warning parent whence text])
+      (empty text)
+       (flink [addcomment-page parent (get-user _) whence text retry*])
+      (oversubmitting user ip 'comment)
+       (flink [msgpage user toofast*])
+       (atlet c (create-comment parent (md-from-form text) user ip)
+         (comment-ban-test user c ip text comment-kill* comment-ignore*)
+         (if (bad-user user) (kill c 'ignored/karma))
+         (submit-item user c)
+         whence)))
+
+(def bad-user (u)
+  (or (ignored u) (< (karma u) comment-threshold*)))
+
+(def create-comment (parent text user ip)
+  (newslog ip user 'comment (parent 'id))
+  (let c (inst 'item 'type 'comment 'id (new-item-id)
+                     'text text 'parent parent!id 'by user 'ip ip)
+    (save-item c)
+    (= (items* c!id) c)
+    (push c!id parent!kids)
+    (save-item parent)
+    (push c comments*)
+    c))
+
+
+; Comment Display
+
+(def display-comment-tree (c user whence (o indent 0) (o initialpar))
+  (when (cansee-descendant user c)
+    (display-1comment c user whence indent initialpar)
+    (display-subcomments c user whence (+ indent 1))))
+
+(def display-1comment (c user whence indent showpar)
+  (row (tab (display-comment nil c user whence t indent showpar showpar))))
+
+(def display-subcomments (c user whence (o indent 0))
+  (each k (sort (compare > frontpage-rank:item) c!kids)
+    (display-comment-tree (item k) user whence indent)))
+
+(def display-comment (n c user whence (o astree) (o indent 0) 
+                                      (o showpar) (o showon))
+  (tr (display-item-number n)
+      (when astree (td (hspace (* indent 40))))
+      (tag (td valign 'top) (votelinks c user whence t))
+      (display-comment-body c user whence astree indent showpar showon)))
+
+; Comment caching doesn't make generation of comments significantly
+; faster, but may speed up everything else by generating less garbage.
+
+; It might solve the same problem more generally to make html code
+; more efficient.
+
+(= comment-cache* (table) comment-cache-timeout* (table) cc-window* 10000)
+
+(= comments-printed* 0 cc-hits* 0)
+
+(= comment-caching* t) 
+
+; Cache comments generated for nil user that are over an hour old.
+; Only try to cache most recent 10k items.  But this window moves,
+; so if server is running a long time could have more than that in
+; cache.  Probably should actively gc expired cache entries.
+
+(def display-comment-body (c user whence astree indent showpar showon)
+  (++ comments-printed*)
+  (if (and comment-caching*
+           astree (no showpar) (no showon)
+           (live c)
+           (nor (admin user) (editor user) (author user c))
+           (< (- maxid* c!id) cc-window*)
+           (> (- (seconds) c!time) 60)) ; was 3600
+      (pr (cached-comment-body c user whence indent))
+      (gen-comment-body c user whence astree indent showpar showon)))
+
+(def cached-comment-body (c user whence indent)
+  (or (and (> (or (comment-cache-timeout* c!id) 0) (seconds))
+           (awhen (comment-cache* c!id)
+             (++ cc-hits*)
+             it))
+      (= (comment-cache-timeout* c!id)
+          (cc-timeout c!time)
+         (comment-cache* c!id)
+          (tostring (gen-comment-body c user whence t indent nil nil)))))
+
+; Cache for the remainder of the current minute, hour, or day.
+
+(def cc-timeout (t0)
+  (let age (- (seconds) t0)
+    (+ t0 (if (< age 3600)
+               (* (+ (trunc (/ age    60)) 1)    60)
+              (< age 86400)
+               (* (+ (trunc (/ age  3600)) 1)  3600)
+               (* (+ (trunc (/ age 86400)) 1) 86400)))))
+
+(def gen-comment-body (c user whence astree indent showpar showon)
+  (tag (td class 'default)
+    (let parent (and (or (no astree) showpar) (c 'parent))
+      (tag (div style "margin-top:2px; margin-bottom:-10px; ")
+        (spanclass comhead
+          (itemline c user)
+          (permalink c user)
+          (when parent
+            (when (cansee user c) (pr bar*))
+            (link "parent" (item-url ((item parent) 'id))))
+          (editlink c user)
+          (killlink c user whence)
+          (blastlink c user whence)
+          (deletelink c user whence)
+          ; a hack to check whence but otherwise need an arg just for this
+          (unless (or astree (is whence "newcomments"))
+            (flaglink c user whence))
+          (deadmark c user)
+          (when showon
+            (pr " | on: ")
+            (let s (superparent c)
+              (link (ellipsize s!title 50) (item-url s!id))))))
+      (when (or parent (cansee user c))
+        (br))
+      (spanclass comment
+        (if (~cansee user c)               (pr (pseudo-text c))
+            (nor (live c) (author user c)) (spanclass dead (pr c!text))
+                                           (fontcolor (comment-color c)
+                                             (pr c!text))))
+      (when (and astree (cansee user c) (live c))
+        (para)
+        (tag (font size 1)
+          (if (and (~mem 'neutered c!keys)
+                   (replyable c indent)
+                   (comments-active c))
+              (underline (replylink c whence))
+              (fontcolor sand (pr "-----"))))))))
+
+; For really deeply nested comments, caching could add another reply 
+; delay, but that's ok.
+
+; People could beat this by going to the link url or manually entering 
+; the reply url, but deal with that if they do.
+
+(= reply-decay* 1.8)   ; delays: (0 0 1 3 7 12 18 25 33 42 52 63)
+
+(def replyable (c indent)
+  (or (< indent 2)
+      (> (item-age c) (expt (- indent 1) reply-decay*))))
+
+(def replylink (i whence (o title 'reply))
+  (link title (+ "reply?id=" i!id "&whence=" (urlencode whence))))
+
+(newsop reply (id whence)
+  (with (i      (safe-item id)
+         whence (or (only.urldecode whence) "news"))
+    (if (only.comments-active i)
+        (if user
+            (addcomment-page i user whence)
+            (login-page 'both "You have to be logged in to comment."
+                        (fn (u ip)
+                          (ensure-news-user u)
+                          (newslog ip u 'comment-login)
+                          (addcomment-page i u whence))))
+        (pr "No such item."))))
+
+(def comment-color (c)
+  (if (> c!score 0) black (grayrange c!score)))
+
+(defmemo grayrange (s)
+  (gray (min 230 (round (expt (* (+ (abs s) 2) 900) .6)))))
+
+
+; Threads
+
+(def threads-url (user) (+ "threads?id=" user))
+
+(newsop threads (id) 
+  (if id
+      (threads-page user id)
+      (pr "No user specified.")))
+
+(def threads-page (user subject)
+  (if (profile subject)
+      (withs (title (+ subject "'s comments")
+              label (if (is user subject) "threads" title)
+              here  (threads-url subject))
+        (longpage user (msec) nil label title here
+          (awhen (keep [and (cansee user _) (~subcomment _)]
+                       (comments subject maxend*))
+            (display-threads user it label title here))))
+      (prn "No such user.")))
+
+(def display-threads (user comments label title whence
+                      (o start 0) (o end threads-perpage*))
+  (tab 
+    (each c (cut comments start end)
+      (display-comment-tree c user whence 0 t))
+    (when end
+      (let newend (+ end threads-perpage*)
+        (when (and (<= newend maxend*) (< end (len comments)))
+          (spacerow 10)
+          (row (tab (tr (td (hspace 0))
+                        (td (hspace votewid*))
+                        (tag (td class 'title)
+                          (morelink display-threads
+                                    comments label title end newend))))))))))
+
+(def submissions (user (o limit)) 
+  (map item (firstn limit (uvar user submitted))))
+
+(def comments (user (o limit))
+  (map item (retrieve limit acomment:item (uvar user submitted))))
+  
+(def subcomment (c)
+  (some [and (acomment _) (is _!by c!by) (no _!deleted)]
+        (ancestors c)))
+
+(def ancestors (i)
+  (accum a (trav i!parent a:item self:!parent:item)))
+
+
+; Submitted
+
+(def submitted-url (user) (+ "submitted?id=" user))
+       
+(newsop submitted (id) 
+  (if id 
+      (submitted-page user id)
+      (pr "No user specified.")))
+
+(def submitted-page (user subject)
+  (if (profile subject)
+      (with (label (+ subject "'s submissions")
+             here  (submitted-url subject))
+        (longpage user (msec) nil label label here
+          (if (or (no (ignored subject))
+                  (is user subject)
+                  (seesdead user))
+              (aif (keep [and (metastory _) (cansee user _)]
+                         (submissions subject))
+                   (display-items user it label label here 0 perpage* t)))))
+      (pr "No such user.")))
+
+
+; RSS
+
+(newsop rss () (rsspage nil))
+
+(newscache rsspage user 90 
+  (rss-stories (retrieve perpage* live ranked-stories*)))
+
+(def rss-stories (stories)
+  (tag (rss version "2.0")
+    (tag channel
+      (tag title (pr this-site*))
+      (tag link (pr site-url*))
+      (tag description (pr site-desc*))
+      (each s stories
+        (tag item
+          (let comurl (+ site-url* (item-url s!id))
+            (tag title    (pr (eschtml s!title)))
+            (tag link     (pr (if (blank s!url) comurl (eschtml s!url))))
+            (tag comments (pr comurl))
+            (tag description
+              (cdata (link "Comments" comurl)))))))))
+
+
+; User Stats
+
+(newsop leaders () (leaderspage user))
+
+(= nleaders* 20)
+
+(newscache leaderspage user 1000
+  (longpage user (msec) nil "leaders" "Leaders" "leaders"
+    (sptab
+      (let i 0
+        (each u (firstn nleaders* (leading-users))
+          (tr (tdr:pr (++ i) ".")
+              (td (userlink user u nil))
+              (tdr:pr (karma u))
+              (when (admin user)
+                (tdr:prt (only.num (uvar u avg) 2 t t))))
+          (if (is i 10) (spacerow 30)))))))
+
+(= leader-threshold* 1)  ; redefined later
+
+(def leading-users ()
+  (sort (compare > [karma _])
+        (users [and (> (karma _) leader-threshold*) (~admin _)])))
+
+(adop editors ()
+  (tab (each u (users [is (uvar _ auth) 1])
+         (row (userlink user u)))))
+
+
+(= update-avg-threshold* 0)  ; redefined later
+
+(defbg update-avg 45
+  (unless (or (empty profs*) (no stories*))
+    (update-avg (rand-user [and (only.> (car (uvar _ submitted)) 
+                                        (- maxid* initload*))
+                                (len> (uvar _ submitted) 
+                                      update-avg-threshold*)]))))
+
+(def update-avg (user)
+  (= (uvar user avg) (comment-score user))
+  (save-prof user))
+
+(def rand-user ((o test idfn))
+  (evtil (rand-key profs*) test))
+
+; Ignore the most recent 5 comments since they may still be gaining votes.  
+; Also ignore the highest-scoring comment, since possibly a fluff outlier.
+
+(def comment-score (user)
+  (aif (check (nthcdr 5 (comments user 50)) [len> _ 10])
+       (avg (cdr (sort > (map !score (rem !deleted it)))))
+       nil))
+
+
+; Comment Analysis
+
+; Instead of a separate active op, should probably display this info 
+; implicitly by e.g. changing color of commentlink or by showing the 
+; no of comments since that user last looked.
+
+(newsop active () (active-page user))
+
+(newscache active-page user 600
+  (listpage user (msec) (actives user) "active" "Active Threads"))
+
+(def actives (user (o n maxend*) (o consider 2000))
+  (visible user (rank-stories n consider (memo active-rank))))
+
+(= active-threshold* 1500)
+
+(def active-rank (s)
+  (sum [max 0 (- active-threshold* (item-age _))]
+       (cdr (family s))))
+
+(def family (i) (cons i (mappend family:item i!kids)))
+
+
+(newsop newcomments () (newcomments-page user))
+
+(newscache newcomments-page user 60
+  (listpage user (msec) (visible user (firstn maxend* comments*))
+            "comments" "New Comments" "newcomments" nil))
+
+
+; Doc
+
+(defop formatdoc req
+  (msgpage (get-user req) formatdoc* "Formatting Options"))
+
+(= formatdoc-url* "formatdoc")
+
+(= formatdoc* 
+"Blank lines separate paragraphs.
+<p> Text after a blank line that is indented by two or more spaces is 
+reproduced verbatim.  (This is intended for code.)
+<p> Text surrounded by asterisks is italicized, if the character after the 
+first asterisk isn't whitespace.
+<p> Urls become links, except in the text field of a submission.<br><br>")
+
+
+; Noprocrast
+
+(def check-procrast (user)
+  (or (no user)
+      (no (uvar user noprocrast))
+      (let now (seconds)
+        (unless (uvar user firstview)
+          (reset-procrast user))
+        (or (when (< (/ (- now (uvar user firstview)) 60)
+                     (uvar user maxvisit))
+              (= (uvar user lastview) now)
+              (save-prof user)
+              t)
+            (when (> (/ (- now (uvar user lastview)) 60)
+                     (uvar user minaway))
+              (reset-procrast user)
+              t)))))
+                
+(def reset-procrast (user)
+  (= (uvar user lastview) (= (uvar user firstview) (seconds)))
+  (save-prof user))
+
+(def procrast-msg (user whence)
+  (let m (+ 1 (trunc (- (uvar user minaway)
+                        (minutes-since (uvar user lastview)))))
+    (pr "<b>Get back to work!</b>")
+    (para "Sorry, you can't see this page.  Based on the anti-procrastination
+           parameters you set in your profile, you'll be able to use the site 
+           again in " (plural m "minute") ".")
+    (para "(If you got this message after submitting something, don't worry,
+           the submission was processed.)")
+    (para "To change your anti-procrastination settings, go to your profile 
+           by clicking on your username.  If <tt>noprocrast</tt> is set to 
+           <tt>yes</tt>, you'll be limited to sessions of <tt>maxvisit</tt>
+           minutes, with <tt>minaway</tt> minutes between them.")
+    (para)
+    (w/rlink whence (underline (pr "retry")))
+    ; (hspace 20)
+    ; (w/rlink (do (reset-procrast user) whence) (underline (pr "override")))
+    (br2)))
+
+
+; Reset PW
+
+(defopg resetpw req (resetpw-page (get-user req)))
+
+(def resetpw-page (user (o msg))
+  (minipage "Reset Password"
+    (if msg
+         (pr msg)
+        (blank (uvar user email))
+         (do (pr "Before you do this, please add your email address to your ")
+             (underlink "profile" (user-url user))
+             (pr ". Otherwise you could lose your account if you mistype 
+                  your new password.")))
+    (br2)
+    (uform user req (try-resetpw user (arg req "p"))
+      (single-input "New password: " 'p 20 "reset" t))))
+
+(def try-resetpw (user newpw)
+  (if (len< newpw 4)
+      (resetpw-page user "Passwords should be a least 4 characters long.  
+                          Please choose another.")
+      (do (set-pw user newpw)
+          (newspage user))))
+
+
+; Scrubrules
+
+(defopa scrubrules req
+  (scrub-page (get-user req) scrubrules*))
+
+; If have other global alists, generalize an alist edit page.
+; Or better still generalize vars-form.
+
+(def scrub-page (user rules (o msg nil))
+  (minipage "Scrubrules"
+    (when msg (pr msg) (br2))
+    (uform user req
+           (with (froms (lines (arg req "from"))
+                  tos   (lines (arg req "to")))
+             (if (is (len froms) (len tos))
+                 (do (todisk scrubrules* (map list froms tos))
+                     (scrub-page user scrubrules* "Changes saved."))
+                 (scrub-page user rules "To and from should be same length.")))
+      (pr "From: ")
+      (tag (textarea name 'from 
+                     cols (apply max 20 (map len (map car rules)))
+                     rows (+ (len rules) 3))
+        (apply pr #\newline (intersperse #\newline (map car rules))))
+      (pr " To: ")
+      (tag (textarea name 'to 
+                     cols (apply max 20 (map len (map cadr rules)))
+                     rows (+ (len rules) 3))
+        (apply pr #\newline (intersperse #\newline (map cadr rules))))
+      (br2)
+      (submit "update"))))
+
+
+; Abuse Analysis
+
+(adop badsites ()
+  (sptab 
+    (row "Dead" "Days" "Site" "O" "K" "I" "Users")
+    (each (site deads) (with (banned (banned-site-items)
+                              pairs  (killedsites))
+                         (+ pairs (map [list _ (banned _)]
+                                       (rem (fn (d)
+                                              (some [caris _ d] pairs))
+                                            (keys banned-sites*)))))
+      (let ban (car (banned-sites* site))
+        (tr (tdr (when deads
+                   (onlink (len deads)
+                           (listpage user (msec) deads
+                                     nil (+ "killed at " site) "badsites"))))
+            (tdr (when deads (pr (round (days-since ((car deads) 'time))))))
+            (td site)
+            (td (w/rlink (do (set-site-ban user site nil) "badsites")
+                  (fontcolor (if ban gray.220 black) (pr "x"))))
+            (td (w/rlink (do (set-site-ban user site 'kill) "badsites")
+                  (fontcolor (case ban kill darkred gray.220) (pr "x"))))
+            (td (w/rlink (do (set-site-ban user site 'ignore) "badsites")
+                  (fontcolor (case ban ignore darkred gray.220) (pr "x"))))
+            (td (each u (dedup (map !by deads))
+                  (userlink user u nil)
+                  (pr " "))))))))
+
+(defcache killedsites 300
+  (let bads (table [each-loaded-item i
+                     (awhen (and i!dead (sitename i!url))
+                       (push i (_ it)))])
+    (with (acc nil deadcount (table))
+      (each (site items) bads
+        (let n (len items)
+          (when (> n 2)
+            (= (deadcount site) n)
+            (insort (compare > deadcount:car)
+                    (list site (rev items))
+                    acc))))
+      acc)))
+
+(defcache banned-site-items 300
+  (table [each-loaded-item i
+           (awhen (and i!dead (check (sitename i!url) banned-sites*))
+             (push i (_ it)))]))
+
+; Would be nice to auto unban ips whose most recent submission is > n 
+; days old, but hard to do because of lazy loading.  Would have to keep
+; a table of most recent submission per ip, and only enforce bannnedness
+; if < n days ago.
+
+(adop badips ()
+  (withs ((bads goods) (badips)
+          (subs ips)   (sorted-badips bads goods))
+    (sptab
+      (row "IP" "Days" "Dead" "Live" "Users")
+      (each ip ips
+        (tr (td (let banned (banned-ips* ip)
+                  (w/rlink (do (set-ip-ban user ip (no banned))
+                               "badips")
+                    (fontcolor (if banned darkred) (pr ip)))))
+            (tdr (when (or (goods ip) (bads ip))
+                   (pr (round (days-since 
+                                (max (aif (car (goods ip)) it!time 0) 
+                                     (aif (car (bads  ip)) it!time 0)))))))
+            (tdr (onlink (len (bads ip))
+                         (listpage user (msec) (bads ip)
+                                   nil (+ "dead from " ip) "badips")))
+            (tdr (onlink (len (goods ip))
+                         (listpage user (msec) (goods ip)
+                                   nil (+ "live from " ip) "badips")))
+            (td (each u (subs ip)
+                  (userlink user u nil) 
+                  (pr " "))))))))
+
+(defcache badips 300
+  (with (bads (table) goods (table))
+    (each-loaded-item s
+      (if (and s!dead (commentable s))
+          (push s (bads  s!ip))
+          (push s (goods s!ip))))
+    (each (k v) bads  (zap rev (bads  k)))
+    (each (k v) goods (zap rev (goods k)))
+    (list bads goods)))
+
+(def sorted-badips (bads goods)
+  (withs (ips  (let ips (rem [len< (bads _) 2] (keys bads))
+                (+ ips (rem [mem _ ips] (keys banned-ips*))))
+          subs (table 
+                 [each ip ips
+                   (= (_ ip) (dedup (map !by (+ (bads ip) (goods ip)))))]))
+    (list subs
+          (sort (compare > (memo [badness (subs _) (bads _) (goods _)]))
+                ips))))
+
+(def badness (subs bads goods)
+  (* (/ (len bads)
+        (max .9 (expt (len goods) 2))
+        (expt (+ (days-since (aif (car bads) it!time 0))
+                 1)
+              2))
+     (if (len> subs 1) 20 1)))
+
+
+(edop flagged ()
+  (display-selected-items user [retrieve maxend* flagged _] "flagged"))
+
+(def flagged (i) 
+  (and (live i)
+       (~mem 'nokill i!keys)
+       (len> i!flags many-flags*)))
+
+
+(edop killed ()
+  (display-selected-items user [retrieve maxend* !dead _] "killed"))
+
+(def display-selected-items (user f whence)
+  (display-items user (f stories*) nil nil whence)
+  (vspace 35)
+  (color-stripe textgray)
+  (vspace 35)
+  (display-items user (f comments*) nil nil whence))
+
+
+; Rather useless thus; should add more data.
+
+(adop badguys ()
+  (tab (each u (sort (compare > [uvar _ created])
+                     (users [ignored _]))
+         (row (userlink user u nil)))))
+
+(adop badlogins ()  (logins-page bad-logins*))
+
+(adop goodlogins () (logins-page good-logins*))
+
+(def logins-page (source)
+  (sptab (each (time ip user) (firstn 100 (rev (qlist source)))
+           (row time ip user))))
+
+
+; Stats
+
+(adop optimes ()
+  (sptab
+    (tr (td "op") (tdr "avg") (tdr "med") (tdr "req") (tdr "total"))
+    (spacerow 10)
+    (each name (sort < newsop-names*)
+      (tr (td name)
+          (let ms (only.avg (qlist (optimes* name)))
+            (tdr:prt (only.round ms))
+            (tdr:prt (only.med (qlist (optimes* name))))
+            (let n (opcounts* name)
+              (tdr:prt n)
+              (tdr:prt (and n (round (/ (* n ms) 1000))))))))))
+
+(defop topcolors req
+  (minipage "Custom Colors"
+    (tab 
+      (each c (dedup (map downcase (trues [uvar _ topcolor] (users))))
+        (tr (td c) (tdcolor (hex>color c) (hspace 30)))))))
+
+
diff --git a/lib/pprint.arc b/lib/pprint.arc
new file mode 100644
index 0000000..e4d3c4e
--- /dev/null
+++ b/lib/pprint.arc
@@ -0,0 +1,80 @@
+; Pretty-Printing.  Spun off 4 Aug 06.
+
+; todo: indentation of long ifs; quasiquote, unquote, unquote-splicing
+           
+(= bodops* (fill-table (table)
+   '(let 2 with 1 while 1 def 2 fn 1 rfn 2 afn 1
+     when 1 unless 1 after 1 whilet 2 for 3 each 2 whenlet 2 awhen 1
+     whitepage 0 tag 1 form 1 aform 1 aformh 1 w/link 1 textarea 3
+   )))
+
+(= oneline* 35) ; print exprs less than this long on one line
+
+; If returns nil, can assume it didn't have to break expr.
+  
+(def ppr (expr (o col 0) (o noindent nil))
+  (if (or (atom expr) (dotted expr))
+       (do (unless noindent (sp col))
+           (write expr)
+           nil)
+      (is (car expr) 'quote)
+       (do (unless noindent (sp col))
+           (pr "'")
+           (ppr (cadr expr) (+ col 1) t))
+      (bodops* (car expr))
+       (do (unless noindent (sp col))
+           (let whole (tostring (write expr))
+             (if (< (len whole) oneline*)
+                 (do (pr whole) nil)
+                 (ppr-progn expr col noindent))))
+      (do (unless noindent (sp col))
+          (let whole (tostring (write expr))
+            (if (< (len whole) oneline*)
+                (do (pr whole) nil)
+                (ppr-call expr col noindent))))))
+
+(def ppr-progn (expr col noindent)
+  (lpar)
+  (let n (bodops* (car expr))
+    (let str (tostring (write-spaced (firstn n expr)))
+      (unless (is n 0) (pr str) (sp))
+      (ppr (expr n) (+ col (len str) 2) t))
+    (map (fn (e) (prn) (ppr e (+ col 2)))
+         (nthcdr (+ n 1) expr)))
+  (rpar)
+  t)
+             
+(def ppr-call (expr col noindent)
+  (lpar)
+  (let carstr (tostring (write (car expr)))
+    (pr carstr)
+    (if (cdr expr)
+        (do (sp)
+            (let broke (ppr (cadr expr) (+ col (len carstr) 2) t)
+              (pprest (cddr expr)
+                      (+ col (len carstr) 2)
+                      (no broke)))
+            t)
+        (do (rpar) t))))
+       
+(def pprest (exprs col (o oneline t))
+  (if (and oneline
+           (all (fn (e)
+                  (or (atom e) (and (is (car e) 'quote) (atom (cadr e)))))
+                exprs))
+      (do (map (fn (e) (pr " ") (write e))
+               exprs)
+          (rpar))
+      (do (when exprs
+            (each e exprs (prn) (ppr e col)))
+          (rpar))))
+                
+(def write-spaced (xs)
+  (when xs
+    (write (car xs))
+    (each x (cdr xs) (pr " ") (write x))))
+  
+(def sp ((o n 1)) (repeat n (pr " ")))
+(def lpar () (pr "("))
+(def rpar () (pr ")"))
+
diff --git a/lib/prompt.arc b/lib/prompt.arc
new file mode 100644
index 0000000..af34e53
--- /dev/null
+++ b/lib/prompt.arc
@@ -0,0 +1,119 @@
+; Prompt: Web-based programming application.  4 Aug 06.
+
+(= appdir* "arc/apps/")
+
+(defop prompt req 
+  (let user (get-user req)
+    (if (admin user)
+        (prompt-page user)
+        (pr "Sorry."))))
+
+(def prompt-page (user . msg)
+  (ensure-dir appdir*)
+  (ensure-dir (string appdir* user))
+  (whitepage
+    (prbold "Prompt")
+    (hspace 20)
+    (pr user " | ")
+    (link "logout")
+    (when msg (hspace 10) (apply pr msg))
+    (br2)
+    (tag (table border 0 cellspacing 10)
+      (each app (dir (+ appdir* user))
+        (tr (td app)
+            (td (ulink user 'edit   (edit-app user app)))
+            (td (ulink user 'run    (run-app  user app)))
+            (td (hspace 40)
+                (ulink user 'delete (rem-app  user app))))))
+    (br2)
+    (aform (fn (req)
+             (when-umatch user req
+               (aif (goodname (arg req "app"))
+                    (edit-app user it)
+                    (prompt-page user "Bad name."))))
+       (tab (row "name:" (input "app") (submit "create app"))))))
+
+(def app-path (user app) 
+  (and user app (+ appdir* user "/" app)))
+
+(def read-app (user app)
+  (aand (app-path user app) 
+        (file-exists it)
+        (readfile it)))
+
+(def write-app (user app exprs)
+  (awhen (app-path user app)
+    (w/outfile o it 
+      (each e exprs (write e o)))))
+
+(def rem-app (user app)
+  (let file (app-path user app)
+    (if (file-exists file)
+        (do (rmfile (app-path user app))
+            (prompt-page user "Program " app " deleted."))
+        (prompt-page user "No such app."))))
+
+(def edit-app (user app)
+  (whitepage
+    (pr "user: " user " app: " app)
+    (br2)
+    (aform (fn (req)
+             (let u2 (get-user req)
+               (if (is u2 user)
+                   (do (when (is (arg req "cmd") "save")
+                         (write-app user app (readall (arg req "exprs"))))
+                       (prompt-page user))
+                   (login-page 'both nil
+                               (fn (u ip) (prompt-page u))))))
+      (textarea "exprs" 10 82
+        (pprcode (read-app user app)))
+      (br2)
+      (buts 'cmd "save" "cancel"))))
+
+(def pprcode (exprs) 
+  (each e exprs
+    (ppr e) 
+    (pr "\n\n")))
+
+(def view-app (user app)
+  (whitepage
+    (pr "user: " user " app: " app)
+    (br2)
+    (tag xmp (pprcode (read-app user app)))))
+
+(def run-app (user app)
+  (let exprs (read-app user app)
+    (if exprs 
+        (on-err (fn (c) (pr "Error: " (details c)))
+          (fn () (map eval exprs)))
+        (prompt-page user "Error: No application " app " for user " user))))
+
+(wipe repl-history*)
+
+(defop repl req
+  (if (admin (get-user req))
+      (replpage req)
+      (pr "Sorry.")))
+
+(def replpage (req)
+  (whitepage
+    (repl (readall (or (arg req "expr") "")) "repl")))
+
+(def repl (exprs url)
+    (each expr exprs 
+      (on-err (fn (c) (push (list expr c t) repl-history*))
+              (fn () 
+                (= that (eval expr) thatexpr expr)
+                (push (list expr that) repl-history*))))
+    (form url
+      (textarea "expr" 8 60)
+      (sp) 
+      (submit))
+    (tag xmp
+      (each (expr val err) (firstn 20 repl-history*)
+        (pr "> ")
+        (ppr expr)
+        (prn)
+        (prn (if err "Error: " "")
+             (ellipsize (tostring (write val)) 800)))))
+
diff --git a/lib/srv.arc b/lib/srv.arc
new file mode 100644
index 0000000..65db716
--- /dev/null
+++ b/lib/srv.arc
@@ -0,0 +1,573 @@
+; HTTP Server.
+
+; To improve performance with static files, set static-max-age*.
+
+(= arcdir* "arc/" logdir* "arc/logs/" staticdir* "static/")
+
+(= quitsrv* nil breaksrv* nil) 
+
+(def serve ((o port 8080))
+  (wipe quitsrv*)
+  (ensure-srvdirs)
+  (map [apply new-bgthread _] pending-bgthreads*)
+  (w/socket s port
+    (setuid 2) ; XXX switch from root to pg
+    (prn "ready to serve port " port)
+    (flushout)
+    (= currsock* s)
+    (until quitsrv*
+      (handle-request s breaksrv*)))
+  (prn "quit server"))
+
+(def serve1 ((o port 8080))
+  (w/socket s port (handle-request s t)))
+
+(def ensure-srvdirs ()
+  (map ensure-dir (list arcdir* logdir* staticdir*)))
+
+(= srv-noisy* nil)
+
+; http requests currently capped at 2 meg by socket-accept
+
+; should threads process requests one at a time? no, then
+; a browser that's slow consuming the data could hang the
+; whole server.
+
+; wait for a connection from a browser and start a thread
+; to handle it. also arrange to kill that thread if it
+; has not completed in threadlife* seconds.
+
+(= threadlife* 30  requests* 0  requests/ip* (table)  
+   throttle-ips* (table)  ignore-ips* (table)  spurned* (table))
+
+(def handle-request (s breaksrv)
+  (if breaksrv
+      (handle-request-1 s)
+      (errsafe (handle-request-1 s))))
+
+(def handle-request-1 (s)
+  (let (i o ip) (socket-accept s)
+    (if (and (or (ignore-ips* ip) (abusive-ip ip))
+             (++ (spurned* ip 0)))
+        (force-close i o)
+        (do (++ requests*)
+            (++ (requests/ip* ip 0))
+            (with (th1 nil th2 nil)
+              (= th1 (thread
+                       (after (handle-request-thread i o ip)
+                              (close i o)
+                              (kill-thread th2))))
+              (= th2 (thread
+                       (sleep threadlife*)
+                       (unless (dead th1)
+                         (prn "srv thread took too long for " ip))
+                       (break-thread th1)
+                       (force-close i o))))))))
+
+; Returns true if ip has made req-limit* requests in less than
+; req-window* seconds.  If an ip is throttled, only 1 request is 
+; allowed per req-window* seconds.  If an ip makes req-limit* 
+; requests in less than dos-window* seconds, it is a treated as a DoS
+; attack and put in ignore-ips* (for this server invocation).
+
+; To adjust this while running, adjust the req-window* time, not 
+; req-limit*, because algorithm doesn't enforce decreases in the latter.
+
+(= req-times* (table) req-limit* 30 req-window* 10 dos-window* 2)
+
+(def abusive-ip (ip)
+  (and (only.> (requests/ip* ip) 250)
+       (let now (seconds)
+         (do1 (if (req-times* ip)
+                  (and (>= (qlen (req-times* ip)) 
+                           (if (throttle-ips* ip) 1 req-limit*))
+                       (let dt (- now (deq (req-times* ip)))
+                         (if (< dt dos-window*) (set (ignore-ips* ip)))
+                         (< dt req-window*)))
+                  (do (= (req-times* ip) (queue))
+                      nil))
+              (enq now (req-times* ip))))))
+
+(def handle-request-thread (i o ip)
+  (with (nls 0 lines nil line nil responded nil t0 (msec))
+    (after
+      (whilet c (unless responded (readc i))
+        (if srv-noisy* (pr c))
+        (if (is c #\newline)
+            (if (is (++ nls) 2) 
+                (let (type op args n cooks) (parseheader (rev lines))
+                  (let t1 (msec)
+                    (case type
+                      get  (respond o op args cooks ip)
+                      post (handle-post i o op args n cooks ip)
+                           (respond-err o "Unknown request: " (car lines)))
+                    (log-request type op args cooks ip t0 t1)
+                    (set responded)))
+                (do (push (string (rev line)) lines)
+                    (wipe line)))
+            (unless (is c #\return)
+              (push c line)
+              (= nls 0))))
+      (close i o)))
+  (harvest-fnids))
+
+(def log-request (type op args cooks ip t0 t1)
+  (with (parsetime (- t1 t0) respondtime (- (msec) t1))
+    (srvlog 'srv ip 
+                 parsetime 
+                 respondtime 
+                 (if (> (+ parsetime respondtime) 1000) "***" "")
+                 type
+                 op
+                 (let arg1 (car args)
+                   (if (caris arg1 "fnid") "" arg1))
+                 cooks)))
+
+; Could ignore return chars (which come from textarea fields) here by
+; (unless (is c #\return) (push c line))
+
+(def handle-post (i o op args n cooks ip)
+  (if srv-noisy* (pr "Post Contents: "))
+  (if (no n)
+      (respond-err o "Post request without Content-Length.")
+      (let line nil
+        (whilet c (and (> n 0) (readc i))
+          (if srv-noisy* (pr c))
+          (-- n)
+          (push c line)) 
+        (if srv-noisy* (pr "\n\n"))
+        (respond o op (+ (parseargs (string (rev line))) args) cooks ip))))
+
+(= header* "HTTP/1.1 200 OK
+Content-Type: text/html; charset=utf-8
+Connection: close")
+
+(= type-header* (table))
+
+(def gen-type-header (ctype)
+  (+ "HTTP/1.0 200 OK
+Content-Type: "
+     ctype
+     "
+Connection: close"))
+
+(map (fn ((k v)) (= (type-header* k) (gen-type-header v)))
+     '((gif       "image/gif")
+       (jpg       "image/jpeg")
+       (png       "image/png")
+       (text/html "text/html; charset=utf-8")))
+
+(= rdheader* "HTTP/1.0 302 Moved")
+
+(= srvops* (table) redirector* (table) optimes* (table) opcounts* (table))
+
+(def save-optime (name elapsed)
+  ; this is the place to put a/b testing
+  ; toggle a flag and push elapsed into one of two lists
+  (++ (opcounts* name 0))
+  (unless (optimes* name) (= (optimes* name) (queue)))
+  (enq-limit elapsed (optimes* name) 1000))
+
+; For ops that want to add their own headers.  They must thus remember 
+; to prn a blank line before anything meant to be part of the page.
+
+(mac defop-raw (name parms . body)
+  (w/uniq t1
+    `(= (srvops* ',name) 
+        (fn ,parms 
+          (let ,t1 (msec)
+            (do1 (do ,@body)
+                 (save-optime ',name (- (msec) ,t1))))))))
+
+(mac defopr-raw (name parms . body)
+  `(= (redirector* ',name) t
+      (srvops* ',name)     (fn ,parms ,@body)))
+
+(mac defop (name parm . body)
+  (w/uniq gs
+    `(do (wipe (redirector* ',name))
+         (defop-raw ,name (,gs ,parm) 
+           (w/stdout ,gs (prn) ,@body)))))
+
+; Defines op as a redirector.  Its retval is new location.
+
+(mac defopr (name parm . body)
+  (w/uniq gs
+    `(do (set (redirector* ',name))
+         (defop-raw ,name (,gs ,parm)
+           ,@body))))
+
+;(mac testop (name . args) `((srvops* ',name) ,@args))
+
+(deftem request
+  args  nil
+  cooks nil
+  ip    nil)
+
+(= unknown-msg* "Unknown." max-age* (table) static-max-age* nil)
+
+(def respond (str op args cooks ip)
+  (w/stdout str
+    (iflet f (srvops* op)
+           (let req (inst 'request 'args args 'cooks cooks 'ip ip)
+             (if (redirector* op)
+                 (do (prn rdheader*)
+                     (prn "Location: " (f str req))
+                     (prn))
+                 (do (prn header*)
+                     (awhen (max-age* op)
+                       (prn "Cache-Control: max-age=" it))
+                     (f str req))))
+           (let filetype (static-filetype op)
+             (aif (and filetype (file-exists (string staticdir* op)))
+                  (do (prn (type-header* filetype))
+                      (awhen static-max-age*
+                        (prn "Cache-Control: max-age=" it))
+                      (prn)
+                      (w/infile i it
+                        (whilet b (readb i)
+                          (writeb b str))))
+                  (respond-err str unknown-msg*))))))
+
+(def static-filetype (sym)
+  (let fname (coerce sym 'string)
+    (and (~find #\/ fname)
+         (case (downcase (last (check (tokens fname #\.) ~single)))
+           "gif"  'gif
+           "jpg"  'jpg
+           "jpeg" 'jpg
+           "png"  'png
+           "css"  'text/html
+           "txt"  'text/html
+           "htm"  'text/html
+           "html" 'text/html
+           "arc"  'text/html
+           ))))
+
+(def respond-err (str msg . args)
+  (w/stdout str
+    (prn header*)
+    (prn)
+    (apply pr msg args)))
+
+(def parseheader (lines)
+  (let (type op args) (parseurl (car lines))
+    (list type
+          op
+          args
+          (and (is type 'post)
+               (some (fn (s)
+                       (and (begins s "Content-Length:")
+                            (errsafe:coerce (cadr (tokens s)) 'int)))
+                     (cdr lines)))
+          (some (fn (s)
+                  (and (begins s "Cookie:")
+                       (parsecookies s)))
+                (cdr lines)))))
+
+; (parseurl "GET /p1?foo=bar&ug etc") -> (get p1 (("foo" "bar") ("ug")))
+
+(def parseurl (s)
+  (let (type url) (tokens s)
+    (let (base args) (tokens url #\?)
+      (list (sym (downcase type))
+            (sym (cut base 1))
+            (if args
+                (parseargs args)
+                nil)))))
+
+; I don't urldecode field names or anything in cookies; correct?
+
+(def parseargs (s)
+  (map (fn ((k v)) (list k (urldecode v)))
+       (map [tokens _ #\=] (tokens s #\&))))
+
+(def parsecookies (s)
+  (map [tokens _ #\=] 
+       (cdr (tokens s [or (whitec _) (is _ #\;)]))))
+
+(def arg (req key) (alref req!args key))
+
+; *** Warning: does not currently urlencode args, so if need to do
+; that replace v with (urlencode v).
+
+(def reassemble-args (req)
+  (aif req!args
+       (apply string "?" (intersperse '&
+                                      (map (fn ((k v))
+                                             (string k '= v))
+                                           it)))
+       ""))
+
+(= fns* (table) fnids* nil timed-fnids* nil)
+
+; count on huge (expt 64 10) size of fnid space to avoid clashes
+
+(def new-fnid ()
+  (check (sym (rand-string 10)) ~fns* (new-fnid)))
+
+(def fnid (f)
+  (atlet key (new-fnid)
+    (= (fns* key) f)
+    (push key fnids*)
+    key))
+
+(def timed-fnid (lasts f)
+  (atlet key (new-fnid)
+    (= (fns* key) f)
+    (push (list key (seconds) lasts) timed-fnids*)
+    key))
+
+; Within f, it will be bound to the fn's own fnid.  Remember that this is
+; so low-level that need to generate the newline to separate from the headers
+; within the body of f.
+
+(mac afnid (f)
+  `(atlet it (new-fnid)
+     (= (fns* it) ,f)
+     (push it fnids*)
+     it))
+
+;(defop test-afnid req
+;  (tag (a href (url-for (afnid (fn (req) (prn) (pr "my fnid is " it)))))
+;    (pr "click here")))
+
+; To be more sophisticated, instead of killing fnids, could first 
+; replace them with fns that tell the server it's harvesting too 
+; aggressively if they start to get called.  But the right thing to 
+; do is estimate what the max no of fnids can be and set the harvest 
+; limit there-- beyond that the only solution is to buy more memory.
+
+(def harvest-fnids ((o n 50000))  ; was 20000
+  (when (len> fns* n) 
+    (pull (fn ((id created lasts))
+            (when (> (since created) lasts)    
+              (wipe (fns* id))
+              t))
+          timed-fnids*)
+    (atlet nharvest (trunc (/ n 10))
+      (let (kill keep) (split (rev fnids*) nharvest)
+        (= fnids* (rev keep)) 
+        (each id kill 
+          (wipe (fns* id)))))))
+
+(= fnurl* "/x" rfnurl* "/r" rfnurl2* "/y" jfnurl* "/a")
+
+(= dead-msg* "\nUnknown or expired link.")
+ 
+(defop-raw x (str req)
+  (w/stdout str 
+    (aif (fns* (sym (arg req "fnid")))
+         (it req)
+         (pr dead-msg*))))
+
+(defopr-raw y (str req)
+  (aif (fns* (sym (arg req "fnid")))
+       (w/stdout str (it req))
+       "deadlink"))
+
+; For asynchronous calls; discards the page.  Would be better to tell
+; the fn not to generate it.
+
+(defop-raw a (str req)
+  (aif (fns* (sym (arg req "fnid")))
+       (tostring (it req))))
+
+(defopr r req
+  (aif (fns* (sym (arg req "fnid")))
+       (it req)
+       "deadlink"))
+
+(defop deadlink req
+  (pr dead-msg*))
+
+(def url-for (fnid)
+  (string fnurl* "?fnid=" fnid))
+
+(def flink (f)
+  (string fnurl* "?fnid=" (fnid (fn (req) (prn) (f req)))))
+
+(def rflink (f)
+  (string rfnurl* "?fnid=" (fnid f)))
+  
+; Since it's just an expr, gensym a parm for (ignored) args.
+
+(mac w/link (expr . body)
+  `(tag (a href (flink (fn (,(uniq)) ,expr)))
+     ,@body))
+
+(mac w/rlink (expr . body)
+  `(tag (a href (rflink (fn (,(uniq)) ,expr)))
+     ,@body))
+
+(mac onlink (text . body)
+  `(w/link (do ,@body) (pr ,text)))
+
+(mac onrlink (text . body)
+  `(w/rlink (do ,@body) (pr ,text)))
+
+; bad to have both flink and linkf; rename flink something like fnid-link
+
+(mac linkf (text parms . body)
+  `(tag (a href (flink (fn ,parms ,@body))) (pr ,text)))
+
+(mac rlinkf (text parms . body)
+  `(tag (a href (rflink (fn ,parms ,@body))) (pr ,text)))
+
+;(defop top req (linkf 'whoami? (req) (pr "I am " (get-user req))))
+
+;(defop testf req (w/link (pr "ha ha ha") (pr "laugh")))
+
+(mac w/link-if (test expr . body)
+  `(tag-if ,test (a href (flink (fn (,(uniq)) ,expr)))
+     ,@body))
+
+(def fnid-field (id)
+  (gentag input type 'hidden name 'fnid value id))
+
+; f should be a fn of one arg, which will be http request args.
+
+(def fnform (f bodyfn (o redir))
+  (tag (form method 'post action (if redir rfnurl2* fnurl*))
+    (fnid-field (fnid f))
+    (bodyfn)))
+
+; Could also make a version that uses just an expr, and var capture.
+; Is there a way to ensure user doesn't use "fnid" as a key?
+
+(mac aform (f . body)
+  (w/uniq ga
+    `(tag (form method 'post action fnurl*)
+       (fnid-field (fnid (fn (,ga)
+                           (prn)
+                           (,f ,ga))))
+       ,@body)))
+
+;(defop test1 req
+;  (fnform (fn (req) (prn) (pr req))
+;          (fn () (single-input "" 'foo 20 "submit"))))
+ 
+;(defop test2 req
+;  (aform (fn (req) (pr req))
+;    (single-input "" 'foo 20 "submit")))
+
+; Like aform except creates a fnid that will last for lasts seconds
+; (unless the server is restarted).
+
+(mac taform (lasts f . body)
+  (w/uniq (gl gf gi ga)
+    `(withs (,gl ,lasts
+             ,gf (fn (,ga) (prn) (,f ,ga)))
+       (tag (form method 'post action fnurl*)
+         (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
+         ,@body))))
+
+(mac arform (f . body)
+  `(tag (form method 'post action rfnurl*)
+     (fnid-field (fnid ,f))
+     ,@body))
+
+; overlong
+
+(mac tarform (lasts f . body)
+  (w/uniq (gl gf)
+    `(withs (,gl ,lasts ,gf ,f)
+       (tag (form method 'post action rfnurl*)
+         (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
+         ,@body))))
+
+(mac aformh (f . body)
+  `(tag (form method 'post action fnurl*)
+     (fnid-field (fnid ,f))
+     ,@body))
+
+(mac arformh (f . body)
+  `(tag (form method 'post action rfnurl2*)
+     (fnid-field (fnid ,f))
+     ,@body))
+
+; only unique per server invocation
+
+(= unique-ids* (table))
+
+(def unique-id ((o len 8))
+  (let id (sym (rand-string (max 5 len)))
+    (if (unique-ids* id)
+        (unique-id)
+        (= (unique-ids* id) id))))
+
+(def srvlog (type . args)
+  (w/appendfile o (logfile-name type)
+    (w/stdout o (atomic (apply prs (seconds) args) (prn)))))
+
+(def logfile-name (type)
+  (string logdir* type "-" (memodate)))
+
+(with (lastasked nil lastval nil)
+
+(def memodate ()
+  (let now (seconds)
+    (if (or (no lastasked) (> (- now lastasked) 60))
+        (= lastasked now lastval (datestring))
+        lastval)))
+
+)
+
+(defop || req (pr "It's alive."))
+
+(defop topips req
+  (when (admin (get-user req))
+    (whitepage
+      (sptab
+        (each ip (let leaders nil 
+                   (maptable (fn (ip n)
+                               (when (> n 100)
+                                 (insort (compare > requests/ip*)
+                                         ip
+                                         leaders)))
+                             requests/ip*)
+                   leaders)
+          (let n (requests/ip* ip)
+            (row ip n (pr (num (* 100 (/ n requests*)) 1)))))))))
+
+(defop spurned req
+  (when (admin (get-user req))
+    (whitepage
+      (sptab
+        (map (fn ((ip n)) (row ip n))
+             (sortable spurned*))))))
+
+; eventually promote to general util
+
+(def sortable (ht (o f >))
+  (let res nil
+    (maptable (fn kv
+                (insort (compare f cadr) kv res))
+              ht)
+    res))
+
+
+; Background Threads
+
+(= bgthreads* (table) pending-bgthreads* nil)
+
+(def new-bgthread (id f sec)
+  (aif (bgthreads* id) (break-thread it))
+  (= (bgthreads* id) (new-thread (fn () 
+                                   (while t
+                                     (sleep sec)
+                                     (f))))))
+
+; should be a macro for this?
+
+(mac defbg (id sec . body)
+  `(do (pull [caris _ ',id] pending-bgthreads*)
+       (push (list ',id (fn () ,@body) ,sec) 
+             pending-bgthreads*)))
+
+
+
+; Idea: make form fields that know their value type because of
+; gensymed names, and so the receiving fn gets args that are not
+; strings but parsed values.
+
diff --git a/lib/strings.arc b/lib/strings.arc
new file mode 100644
index 0000000..b80bc59
--- /dev/null
+++ b/lib/strings.arc
@@ -0,0 +1,226 @@
+; Matching.  Spun off 29 Jul 06.
+
+; arc> (tostring (writec (coerce 133 'char)))
+;
+;> (define ss (open-output-string))
+;> (write-char (integer->char 133) ss)
+;> (get-output-string ss)
+;"\u0085"
+
+(def tokens (s (o sep whitec))
+  (let test (testify sep)
+    (let rec (afn (cs toks tok)
+               (if (no cs)         (consif tok toks)
+                   (test (car cs)) (self (cdr cs) (consif tok toks) nil)
+                                   (self (cdr cs) toks (cons (car cs) tok))))
+      (rev (map [coerce _ 'string]
+                (map rev (rec (coerce s 'cons) nil nil)))))))
+
+; names of cut, split, halve not optimal
+
+(def halve (s (o sep whitec))
+  (let test (testify sep)
+    (let rec (afn (cs tok)
+               (if (no cs)         (list (rev tok))
+                   (test (car cs)) (list cs (rev tok))
+                                   (self (cdr cs) (cons (car cs) tok))))
+      (rev (map [coerce _ 'string]
+                (rec (coerce s 'cons) nil))))))
+
+; maybe promote to arc.arc, but if so include a list clause
+
+(def positions (test seq)
+  (accum a
+    (let f (testify test)
+      (forlen i seq
+        (if (f (seq i)) (a i))))))
+
+(def lines (s)
+  (accum a
+    ((afn ((p . ps))
+       (if ps
+           (do (a (rem #\return (cut s (+ p 1) (car ps))))
+               (self ps))
+           (a (cut s (+ p 1)))))
+     (cons -1 (positions #\newline s)))))
+
+(def slices (s test)
+  (accum a
+    ((afn ((p . ps))
+       (if ps
+           (do (a (cut s (+ p 1) (car ps)))
+               (self ps))
+           (a (cut s (+ p 1)))))
+     (cons -1 (positions test s)))))
+
+; > (require (lib "uri-codec.ss" "net"))
+;> (form-urlencoded-decode "x%ce%bbx")
+;"xλx"
+
+; first byte: 0-7F, 1 char; c2-df 2; e0-ef 3, f0-f4 4. 
+
+; Fixed for utf8 by pc.
+
+(def urldecode (s)
+ (tostring
+  (forlen i s
+    (caselet c (s i)
+      #\+ (writec #\space)
+      #\% (do (when (> (- (len s) i) 2)
+                (writeb (int (cut s (+ i 1) (+ i 3)) 16)))
+              (++ i 2))
+          (writec c)))))
+
+(def urlencode (s)
+  (tostring 
+    (each c s 
+      (writec #\%)
+      (let i (int c)
+        (if (< i 16) (writec #\0))
+        (pr (coerce i 'string 16))))))
+
+(mac litmatch (pat string (o start 0))
+  (w/uniq (gstring gstart)
+    `(with (,gstring ,string ,gstart ,start)
+       (unless (> (+ ,gstart ,(len pat)) (len ,gstring))
+         (and ,@(let acc nil
+                  (forlen i pat
+                    (push `(is ,(pat i) (,gstring (+ ,gstart ,i)))
+                           acc))
+                  (rev acc)))))))
+
+; litmatch would be cleaner if map worked for string and integer args:
+
+;             ,@(map (fn (n c)  
+;                      `(is ,c (,gstring (+ ,gstart ,n))))
+;                    (len pat)
+;                    pat)
+
+(mac endmatch (pat string)
+  (w/uniq (gstring glen)
+    `(withs (,gstring ,string ,glen (len ,gstring))
+       (unless (> ,(len pat) (len ,gstring))
+         (and ,@(let acc nil
+                  (forlen i pat
+                    (push `(is ,(pat (- (len pat) 1 i)) 
+                               (,gstring (- ,glen 1 ,i)))
+                           acc))
+                  (rev acc)))))))
+
+(def posmatch (pat seq (o start 0))
+  (catch
+    (if (isa pat 'fn)
+        (for i start (- (len seq) 1)
+          (when (pat (seq i)) (throw i)))
+        (for i start (- (len seq) (len pat))
+          (when (headmatch pat seq i) (throw i))))
+    nil))
+
+(def headmatch (pat seq (o start 0))
+  (let p (len pat) 
+    ((afn (i)      
+       (or (is i p) 
+           (and (is (pat i) (seq (+ i start)))
+                (self (+ i 1)))))
+     0)))
+
+(def begins (seq pat (o start 0))
+  (unless (len> pat (- (len seq) start))
+    (headmatch pat seq start)))
+
+(def subst (new old seq)
+  (let boundary (+ (- (len seq) (len old)) 1)
+    (tostring 
+      (forlen i seq
+        (if (and (< i boundary) (headmatch old seq i))
+            (do (++ i (- (len old) 1))
+                (pr new))
+            (pr (seq i)))))))
+
+(def multisubst (pairs seq)
+  (tostring 
+    (forlen i seq
+      (iflet (old new) (find [begins seq (car _) i] pairs)
+        (do (++ i (- (len old) 1))
+            (pr new))
+        (pr (seq i))))))
+
+; not a good name
+
+(def findsubseq (pat seq (o start 0))
+  (if (< (- (len seq) start) (len pat))
+       nil
+      (if (headmatch pat seq start)
+          start
+          (findsubseq pat seq (+ start 1)))))
+
+(def blank (s) (~find ~whitec s))
+
+(def nonblank (s) (unless (blank s) s))
+
+(def trim (s (o where 'both) (o test whitec))
+  (withs (f   (testify test)
+           p1 (pos ~f s))
+    (if p1
+        (cut s 
+             (if (in where 'front 'both) p1 0)
+             (when (in where 'end 'both)
+               (let i (- (len s) 1)
+                 (while (and (> i p1) (f (s i)))
+                   (-- i))
+                 (+ i 1))))
+        "")))
+
+(def num (n (o digits 2) (o trail-zeros nil) (o init-zero nil))
+  (withs (comma
+          (fn (i)
+            (tostring
+              (map [apply pr (rev _)]
+                   (rev (intersperse '(#\,)
+                                     (tuples (rev (coerce (string i) 'cons))
+                                             3))))))
+          abrep
+          (let a (abs n)
+            (if (< digits 1)
+                 (comma (roundup a))
+                (exact a)
+                 (string (comma a)
+                         (when (and trail-zeros (> digits 0))
+                           (string "." (newstring digits #\0))))
+                 (withs (d (expt 10 digits)
+                         m (/ (roundup (* a d)) d)
+                         i (trunc m)
+                         r (abs (trunc (- (* m d) (* i d)))))
+                   (+ (if (is i 0) 
+                          (if (or init-zero (is r 0)) "0" "") 
+                          (comma i))
+                      (withs (rest   (string r)
+                              padded (+ (newstring (- digits (len rest)) #\0)
+                                        rest)
+                              final  (if trail-zeros
+                                         padded
+                                         (trim padded 'end [is _ #\0])))
+                        (string (unless (empty final) ".")
+                                final)))))))
+    (if (and (< n 0) (find [and (digit _) (isnt _ #\0)] abrep))
+        (+ "-" abrep)
+        abrep)))
+        
+
+; English
+
+(def pluralize (n str)
+  (if (or (is n 1) (single n))
+      str
+      (string str "s")))
+
+(def plural (n x)
+  (string n #\  (pluralize n x)))
+
+
+; http://www.eki.ee/letter/chardata.cgi?HTML4=1
+; http://jrgraphix.net/research/unicode_blocks.php?block=1
+; http://home.tiscali.nl/t876506/utf8tbl.html
+; http://www.fileformat.info/info/unicode/block/latin_supplement/utf8test.htm
+; http://en.wikipedia.org/wiki/Utf-8
+; http://unicode.org/charts/charindex2.html
diff --git a/main.go b/main.go
new file mode 100644
index 0000000..60d2574
--- /dev/null
+++ b/main.go
@@ -0,0 +1,54 @@
+package main
+
+import (
+  "fmt"
+  "log"
+  "strings"
+
+  "github.com/chzyer/readline"
+
+  "github.com/hellerve/argos/eval"
+  "github.com/hellerve/argos/parser"
+)
+
+func main() {
+  rl, err := readline.New("argos> ")
+
+  if err != nil {
+    log.Fatal(err)
+  }
+
+  defer rl.Close()
+
+  e := eval.ParentEnv()
+  for {
+    prompt, err := rl.Readline()
+
+    if err != nil {
+      return
+    }
+
+    parsed, err, unconsumed := parser.Parse(prompt)
+
+    if err != nil {
+      fmt.Println(err)
+      continue
+    }
+
+    if len(unconsumed) != 0 {
+      fmt.Println("Unconsumed input:", strings.Join(unconsumed, " "))
+      continue
+    }
+
+    // TODO: how to avoid bindings on error?
+    evald, err := eval.Eval(parsed, e)
+
+
+    if err != nil {
+      fmt.Println(err)
+      continue
+    }
+
+    fmt.Println(evald.Pretty())
+  }
+}
diff --git a/parser/parser.go b/parser/parser.go
new file mode 100644
index 0000000..d12ec6b
--- /dev/null
+++ b/parser/parser.go
@@ -0,0 +1,103 @@
+package parser
+
+import (
+  "errors"
+  "strconv"
+  "strings"
+
+  "github.com/hellerve/argos/ast"
+)
+
+func withoutEmpty(input []string) []string {
+    var r []string
+    for _, str := range input {
+        if str != "" {
+            r = append(r, str)
+        }
+    }
+    return r
+}
+
+func tokenize(input string) []string {
+  return withoutEmpty(strings.Split(strings.Replace(strings.Replace(input, "(", " ( ", -1), ")", " ) ", -1), " "))
+}
+
+func parseValue(input []string) (*ast.AST, error, []string) {
+  var res ast.AST
+
+  f, err := strconv.ParseFloat(input[0], 64)
+
+  if err == nil {
+    res = ast.AST{ast.Num, f}
+    return &res, nil, input[1:]
+  }
+
+  if input[0][0] == '"' {
+    var agg []string
+    for {
+      if len(input) == 0 {
+        return nil, errors.New("Unmatched \""), input
+      }
+      token := input[0]
+      input = input[1:]
+      agg = append(agg, token)
+      if token[len(token)-1] == '"' {
+        break
+      }
+    }
+    res = ast.AST{ast.String, strings.Join(agg, " ")}
+    return &res, nil, input
+  }
+
+  res = ast.AST{ast.Symbol, input[0]}
+  return &res, nil, input[1:]
+}
+
+func parseToken(input []string) (*ast.AST, error, []string) {
+  if len(input) == 0 {
+    return nil, errors.New("Unmatched '('"), input
+  }
+
+  if input[0][0] == '\'' {
+    if (input[0] == "'") {
+      input = input[1:]
+    } else {
+      input = append([]string{input[0][1:]}, input[1:]...)
+    }
+    tmp, err, input := parseToken(input)
+
+    if err != nil {
+      return nil, err, input
+    }
+
+    res := ast.AST{ast.List, []ast.AST{ast.AST{ast.Symbol, "quote"}, *tmp}}
+    return &res, nil, input
+  }
+
+  switch input[0] {
+    case "(": {
+      var l []ast.AST
+      input = input[1:]
+      for input[0] != ")" {
+        elem, err, newInput := parseToken(input)
+
+        if err != nil {
+          return nil, err, input
+        }
+
+        l = append(l, *elem)
+        input = newInput
+      }
+      res := ast.AST{ast.List, l}
+      return &res, nil, input[1:]
+    }
+    case ")": {
+      return nil, errors.New("Unmatched ')'"), input
+    }
+  }
+  return parseValue(input)
+}
+
+func Parse(input string) (*ast.AST, error, []string) {
+  return parseToken(tokenize(input))
+}