The initial contents of arc0.tar.

as.scm

@@ -0,0 +1,16 @@
+; mzscheme -m -f as.scm
+; (tl)
+; (asv)
+; http://localhost:8080
+
+(require mzscheme) ; promise we won't redefine mzscheme bindings
+
+(load "ac.scm") 
+(require "brackets.scm")
+(use-bracket-readtable)
+
+(aload "arc.arc")
+(aload "libs.arc") 
+
+(tl)
+

blog.arc

@@ -0,0 +1,107 @@
+; Blog tool example.  20 Jan 08.
+
+; 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 [coerce _ '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 (coerce id 'int))))
+
+(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
+  (aif (post (arg req "id")) 
+       (post-page (get-user req) it) 
+       (notfound)))
+
+(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)))
+
+(def notfound ()
+  (blogpage (pr "No such post.")))
+
+(defopl newpost req
+  (whitepage
+    (aform (fn (req)
+             (let user (get-user req)
+               (post-page user
+                          (addpost user (arg req "t") (arg req "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
+  (aif (post (arg req "id"))
+       (edit-page (get-user req) it)
+       (notfound)))
+
+(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))
+
+

brackets.scm

@@ -0,0 +1,48 @@
+; From Eli Barzilay, eli@barzilay.org
+
+;> (require "brackets.scm") 
+;> (use-bracket-readtable) 
+;> ([+ _ 1] 10) 
+;11
+
+(module brackets mzscheme
+
+; main reader function for []s
+; recursive read starts with default readtable's [ parser,
+; but nested reads still use the curent readtable:
+
+(define (read-square-brackets ch port src line col pos)
+  `(fn (_)
+     ,(read/recursive port #\[ #f)))
+
+; a readtable that is just like the builtin except for []s
+
+(define bracket-readtable
+  (make-readtable #f #\[ 'terminating-macro read-square-brackets))
+
+; call this to set the global readtable
+
+(provide use-bracket-readtable)
+
+(define (use-bracket-readtable)
+  (current-readtable bracket-readtable))
+
+; these two implement the required functionality for #reader
+
+;(define (*read inp)
+;  (parameterize ((current-readtable bracket-readtable))
+;    (read inp)))
+
+(define (*read . args)
+  (parameterize ((current-readtable bracket-readtable))
+    (read (if (null? args) (current-input-port) (car args)))))
+
+(define (*read-syntax src port)
+  (parameterize ((current-readtable bracket-readtable))
+    (read-syntax src port)))
+
+; and the need to be provided as `read' and `read-syntax'
+
+(provide (rename *read read) (rename *read-syntax read-syntax))
+
+)

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 (pos nonwhite line) (isnt it #\;)))))))
+
+(def codeflat (file)
+  (len (flat (readall (infile file)))))
+
+(def codetree (file)
+  (trav + (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)
+           (+ 1 (or (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 (coerce (car _) 'string))
+                                          (cadr _)])
+                            (list k v (* (len (string k)) v))
+                            ranking)))
+                counts)
+    ranking)))
+
+;(top40 (space-eaters allfiles*))
+

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.