Revert to "added adaptive-integral"

Revert to "added adaptive-integral"

This reverts commit f6f8704df1cc7e8be98dddff1f09810e4ceed507.

;matrix fns

(def init-matrix(dims initval)
  (zap flat dims)
  (if cdr.dims
    (n-of car.dims (init-matrix cdr.dims initval))
    (n-of car.dims initval)))

(def matrix-rank (mat)
  (if atom.mat 0
      (let rec (afn (M r)
		 (if (atom car.M) r
		     (self car.M (+ r 1))))
	(rec mat 1))))

(def zeros dims
  (init-matrix dims 0))

(def ones dims
  (init-matrix dims 1))

(mac elt (mat pos)
  "access the element of the matix given by co-ords listed in pos"
  (if (cdr pos)
      `(elt (,mat ,(last pos)) ,(butlast pos))
      `(,mat ,(car pos))))

(def mat-to-table (mat)
  "coerces a list-of-lists representation of a matrix into a hash table one where the key is a list of indices (0 referenced)"
  (let ans (table)
       (let rec (afn (X pre)
		  (if (atom:car X)
		      (for i 0 (- len.X 1)
			 (= (ans (cons i pre)) X.i))
		      (for i 0 (- len.X 1)
			 (self X.i (cons i pre)))))
	    (rec mat (list)))
       ans))

(def table-to-mat (tab)
  "coerces a table representation of a matrix into a list-of-lists one"
  (let key-val-lis (list)
    (maptable (fn (key val) (push (cons key val) key-val-lis)) tab)
    (let rec (afn (lis)
	       (if (is (len caar.lis) 1)  (map cdr (sort (fn (x y) (< caar.x caar.y)) lis)) ;if there is only one index sort by it
		   (map (fn (tp) (self:map [cons (butlast car._) cdr._] tp))            ;
			    (tuples (sort (fn (x y) (< (last car.x) (last car.y))) lis) ; if there is more than one index: collect into tuples of the rightmost index and list the answers of rec on each tuple
				    (len:keep [is (last car._) 0] lis)))))              ;

	 (rec key-val-lis))))

(def ident-matrix (rank size (o table? nil))
  (let M (mat-to-table (zeros (n-of rank size)))
       (for i 0 (- size 1)
	 (= (M (n-of size i)) 1))
       (if table? M
	   (table-to-mat M))))

(def matrix-multiply (a b)
  "multiplies the matrix a by the matrix b (N.B. Rank one row vectors need to be in the form ((a b c d ...)) /NOT/ (a b c d), i.e. initiated with dims=(1 n) not (n))"
  (with (col (fn (mat i) (map [_ i] mat))
	 result-matrix (list))
    (for rw 0 (- len.a 1)
          (push (let result-row (list)
		  (for cl 0 (- (len b.0) 1)
		       (push (apply + (map * a.rw (col b cl))) result-row))
		  rev.result-row)
		result-matrix))
    rev.result-matrix));could be generalised as a recursive macro to work on arbitrary rank tensors?

(def gauss-elim (mat rhs)
  "solves the linear equations:

mat_00*x_0 + mat_01*x_1 ... mat_0n*x_n = rhs_0
mat_10*x_0 + mat_11*x_1 ... mat_1n*x_n = rhs_1
...
mat_n0*x_0 + mat_n1*x_1 ... mat_nn*x_n = rhs_n

using gaussian elimination and returns a list of x's (N.B. not efficient for large sparce matrices)"
  (zap flat rhs)
  (if (isa mat 'table)
      (withs (MAX 0
	      i 0 j 0 k 0
	      keys (list)
	      _ (maptable (fn (key _) (push key keys)) mat)
	      N (+ 1 (apply max (map car keys))) N2 (+ 1 (apply max (map cadr keys)))
	      X (if (is N N2 len.rhs) (zeros N) (do (pr "N:")(prn N)(pr "N2:")(prn N2)(pr "rhs:")(prn rhs)(err "mat must be a square matrix of the same size as rhs, use 0 elements for equations which dont feature a variable"))))
	  (let M (copy mat)
	       (for i 0 N (= (M (list (+ 1 N2) i)) rhs.i))
	       ;;elimination step
	       (loop (= i 0) (<= i (- N 1)) (++ i)
		  (= MAX i)
		  (loop (= j (+ i 1)) (<= j (- N 1)) (++ j)
		     (if (> (abs:M (list i j)) (abs:M (list i MAX))) (= MAX j)))
		  (if (isnt MAX i) (let temp ()
					(for a 0 N
					     (= temp (M (list a i)))
					     (= (M (list a i)) (M (list a MAX)))
					     (= (M (list a MAX)) temp))))
		  (loop (= j (+ i 1)) (<= j (- N 1)) (++ j)
		     (loop (= k N) (>= k i) (-- k)
			(-- (M (list k j)) (/ (* (M (list k i)) (M (list i j))) (M (list i i))))))) ;;end of elimination step
	       ;;substitution
	       (loop (= j (- N 1)) (>= j 0) (-- j)
		  (let tmp 0.0
		       (loop (= k (+ j 1)) (<= k(- N 1)) (++ k) (++ tmp (* (M (list k j)) X.k)))
		       (= X.j (/ (- (M (list N j)) tmp) (M (list j j)))))))
	  X)))

;calculus fns

(def deriv (f)
  "provides differential of a function of a single vairable"
  (fn (x)
    (let dx (if (is x 0) 1d-9 (abs:* x 1d-9))
       (/ (- (f (+ x dx))
	     (f x))
          dx))))

(mac partial-diff (f n arity)
  "returns deriv function of f (w/ num args ARITY) wrt Nth variable(from 0) "
  (withs (arglis (n-of arity (uniq))
	  a-lis (firstn n arglis)
	  x arglis.n
	  b-lis (nthcdr (+ n 1) arglis))
    `(fn ,arglis
      (let dx (if (is ,x 0) 1d-9 (abs:* ,x 1d-9))
	(/ (- (,f ,@a-lis (+ ,x dx) ,@b-lis)
	      (,f ,@a-lis    ,x     ,@b-lis))
	   dx)))))

(mac partial-diff-vec (f n arity)
  "returns vector with each element differentiated with respect to Nth argument"
  (withs (arglis (n-of arity (uniq))
	  a-lis (firstn n arglis)
	  x arglis.n
	  b-lis (nthcdr (+ n 1) arglis))
    `(fn ,arglis
	(let dx (if (is ,x 0) 1d-9 (abs:* ,x 1d-9))
	   (vec-scale (vec- (,f ,@a-lis	(+ ,x dx) ,@b-lis)
			    (,f ,@a-lis    ,x     ,@b-lis))
		      (/ 1 dx))))))

(def grad (f)
  "gradient of 3D scalar field given by F"
  (fn (x y z)
    (list ((partial-diff f 0 3) x y z)
	  ((partial-diff f 1 3) x y z)
	  ((partial-diff f 2 3) x y z))))

(def div (f)
  "divergence of 3D vector field given by F"
  (fn (x y z)
      (+ (((partial-diff-vec f 0 3) x y z) 0)
	 (((partial-diff-vec f 1 3) x y z) 1)
	 (((partial-diff-vec f 2 3) x y z) 2))))

(def curl (f)
  "curl of 3D vector field given by F"
  (with (d/dx (partial-diff-vec f 0 3)
	 d/dy (partial-diff-vec f 1 3)
	 d/dz (partial-diff-vec f 2 3))
  (fn (x y z)
    (list (- ((d/dy x y z) 2)
	     ((d/dz x y z) 1))
	  (- ((d/dz x y z) 0)
	     ((d/dx x y z) 2))
	  (- ((d/dx x y z) 1)
	     ((d/dy x y z) 0))))))

(def integral (f)
  "returns the integral of a single argument function using Simpson's method"
  (fn (lower upper (o its 100))
    (withs (dx      (/ (- upper lower) its)
	    x       lower
	    current (f x)
	    next    (f (+ x dx))
	    accum   0)
      (while (<= x (- upper dx))
	     (++ accum (/ (+ (* (+ current next) 1/2 dx)
			     (* 2 dx (f (+ x (/ dx 2)))))
			  3))
	     (++ x dx)
	     (= current next)
	     (= next (f:+ x dx)))
      accum)))

; vector fns

(def vec-dot (v1 v2)
  (apply + (map (fn (x y) (* x y)) v1 v2)))

(def vec-cross (v1 v2 . args)
  (if (car args)(vec-cross (vec-cross v1 v2) (car args) (cdr args))
                (list (- (* v1.1 v2.2) (* v2.1 v1.2))
		      (- (* v1.2 v2.0) (* v2.2 v1.0))
		      (- (* v1.0 v2.1) (* v2.0 v1.1)))))

(with (v+ (fn (v1 v2)
	     (map (fn (x y) (+ x y)) v1 v2))
       v- (fn (v1 v2)
	     (map (fn (x y) (- x y)) v1 v2)))

  (def vec+ (v1 . args)
    (if no.args v1
	(reduce v+ (cons v1 args))))

  (def vec- (v1 . args)
    (if no.args (map [- _] v1)
	(v- v1 (apply vec+ args))))
)

(def vec-scale (vec . scalars)
  (let c (apply * scalars)
    (map [* _ c] vec)))

(def quad-add args
  ((afn (tot xs)
     (if no.xs (sqrt tot)
	 (self (+ tot (expt (car xs) 2)) (cdr xs))))
   0 args))

(def vec-norm (vec)
  (vec-scale vec (/ (apply quad-add vec))))

;others

(def square (x) (* x x))
(def cube (x) (* x x x))
(def floor (n) (trunc n))
(def ceiling (n) (int ($.ceiling n)))
(def highbyte (n) (floor (/ n 256)))
(def lowbyte (n) (mod n 256))

(def fact (num)
  "factorial of num (num must be a fixnum)"
  (if (or (< num 0)(no:isa num 'int)) (err "num must be a positive integer")
      ((afn (n x)
	 (if (<= n 1)
	     x
	     (self (- n 1) (* n x))))
       num 1)))

(def n-bessel (n (o terms 100))
  "gives a fn for the nth bessel function of the first kind evaluated at x"
  (fn (x)
    (with (i 0
	   tot 0)
      (while (< i terms)
	     (++ tot (/ (* (expt -1 i) (expt (/ x 2) (+ n i i)))
			(* (fact i) (fact (+ n i)))))
	     (++ i 1))
      tot)))

(def mean lis
  ((afn (tot i x . xs)
     (if no.xs (/ (+ tot x) (+ i 1))
	 (self (+ tot x) (+ i 1) car.xs cdr.xs)))
   0 0 car.lis cdr.lis))

(def std-dev lis
  (let m mean.lis
    (sqrt:/ (apply + (map [expt (- _ m) 2] lis))
	    len.lis)))

(def choose (n x)
  "number of ways of picking n elements from x (ie no. of ways of mixing 2 different sets of identical objects of size n and (- x n))"
  (if (> n x)
      (do (prn "")(pr n)(pr " is greater than ")(prn x))
      (/ (fact x) (* (fact n) (fact (- x n))))))

(def gauss-random (sigma (o middle 0))
  "aproximation to a gausian distributed random with width sigma around middle, max possible deviation +/- 1000sigma"
  (let tot 0
    (for i 0 999
      (++ tot  (- (* (rand) 2.0) 1)))
    (+ (* tot (/ sigma 25)) middle)))

(def quad-roots (a b c)
  "returns roots of the equation ax^2+bx+c=0"
  (let sqroot (sqrt (- (* b b) (* 4 a c)))
    (if (is sqroot 0) (list (/ (- b) 2 a))
	(list (/ (- sqroot b) 2 a)
	      (/ (- 0 sqroot b) 2 a)))))

(= pi 3.14159265358979323846)
(= e  2.71828182845904523536)

;matrix fns

(def init-matrix(dims initval)
  (zap flat dims)
  (if cdr.dims
    (n-of car.dims (init-matrix cdr.dims initval))
    (n-of car.dims initval)))

(def matrix-rank (mat)
  (if atom.mat 0
      (let rec (afn (M r)
		 (if (atom car.M) r
		     (self car.M (+ r 1))))
	(rec mat 1))))

(def zeros dims
  (init-matrix dims 0))

(def ones dims
  (init-matrix dims 1))

(mac elt (mat pos)
  "access the element of the matix given by co-ords listed in pos"
  (if (cdr pos)
      `(elt (,mat ,(last pos)) ,(butlast pos))
      `(,mat ,(car pos))))

(def mat-to-table (mat)
  "coerces a list-of-lists representation of a matrix into a hash table one where the key is a list of indices (0 referenced)"
  (let ans (table)
       (let rec (afn (X pre)
		  (if (atom:car X)
		      (for i 0 (- len.X 1)
			 (= (ans (cons i pre)) X.i))
		      (for i 0 (- len.X 1)
			 (self X.i (cons i pre)))))
	    (rec mat (list)))
       ans))

(def table-to-mat (tab)
  "coerces a table representation of a matrix into a list-of-lists one"
  (let key-val-lis (list)
    (maptable (fn (key val) (push (cons key val) key-val-lis)) tab)
    (let rec (afn (lis)
	       (if (is (len caar.lis) 1)  (map cdr (sort (fn (x y) (< caar.x caar.y)) lis)) ;if there is only one index sort by it
		   (map (fn (tp) (self:map [cons (butlast car._) cdr._] tp))            ;
			    (tuples (sort (fn (x y) (< (last car.x) (last car.y))) lis) ; if there is more than one index: collect into tuples of the rightmost index and list the answers of rec on each tuple
				    (len:keep [is (last car._) 0] lis)))))              ;

	 (rec key-val-lis))))

(def ident-matrix (rank size (o table? nil))
  (let M (mat-to-table (zeros (n-of rank size)))
       (for i 0 (- size 1)
	 (= (M (n-of size i)) 1))
       (if table? M
	   (table-to-mat M))))

(def matrix-multiply (a b)
  "multiplies the matrix a by the matrix b (N.B. Rank one row vectors need to be in the form ((a b c d ...)) /NOT/ (a b c d), i.e. initiated with dims=(1 n) not (n))"
  (with (col (fn (mat i) (map [_ i] mat))
	 result-matrix (list))
    (for rw 0 (- len.a 1)
          (push (let result-row (list)
		  (for cl 0 (- (len b.0) 1)
		       (push (apply + (map * a.rw (col b cl))) result-row))
		  rev.result-row)
		result-matrix))
    rev.result-matrix));could be generalised as a recursive macro to work on arbitrary rank tensors?

(def gauss-elim (mat rhs)
  "solves the linear equations:

mat_00*x_0 + mat_01*x_1 ... mat_0n*x_n = rhs_0
mat_10*x_0 + mat_11*x_1 ... mat_1n*x_n = rhs_1
...
mat_n0*x_0 + mat_n1*x_1 ... mat_nn*x_n = rhs_n

using gaussian elimination and returns a list of x's (N.B. not efficient for large sparce matrices)"
  (zap flat rhs)
  (if (isa mat 'table)
      (withs (MAX 0
	      i 0 j 0 k 0
	      keys (list)
	      _ (maptable (fn (key _) (push key keys)) mat)
	      N (+ 1 (apply max (map car keys))) N2 (+ 1 (apply max (map cadr keys)))
	      X (if (is N N2 len.rhs) (zeros N) (do (pr "N:")(prn N)(pr "N2:")(prn N2)(pr "rhs:")(prn rhs)(err "mat must be a square matrix of the same size as rhs, use 0 elements for equations which dont feature a variable"))))
	  (let M (copy mat)
	       (for i 0 N (= (M (list (+ 1 N2) i)) rhs.i))
	       ;;elimination step
	       (loop (= i 0) (<= i (- N 1)) (++ i)
		  (= MAX i)
		  (loop (= j (+ i 1)) (<= j (- N 1)) (++ j)
		     (if (> (abs:M (list i j)) (abs:M (list i MAX))) (= MAX j)))
		  (if (isnt MAX i) (let temp ()
					(for a 0 N
					     (= temp (M (list a i)))
					     (= (M (list a i)) (M (list a MAX)))
					     (= (M (list a MAX)) temp))))
		  (loop (= j (+ i 1)) (<= j (- N 1)) (++ j)
		     (loop (= k N) (>= k i) (-- k)
			(-- (M (list k j)) (/ (* (M (list k i)) (M (list i j))) (M (list i i))))))) ;;end of elimination step
	       ;;substitution
	       (loop (= j (- N 1)) (>= j 0) (-- j)
		  (let tmp 0.0
		       (loop (= k (+ j 1)) (<= k(- N 1)) (++ k) (++ tmp (* (M (list k j)) X.k)))
		       (= X.j (/ (- (M (list N j)) tmp) (M (list j j)))))))
	  X)))

;calculus fns

(def deriv (f)
  "provides differential of a function of a single vairable"
  (fn (x)
    (let dx (if (is x 0) 1d-9 (abs:* x 1d-9))
       (/ (- (f (+ x dx))
	     (f x))
          dx))))

(mac partial-diff (f n arity)
  "returns deriv function of f (w/ num args ARITY) wrt Nth variable(from 0) "
  (withs (arglis (n-of arity (uniq))
	  a-lis (firstn n arglis)
	  x arglis.n
	  b-lis (nthcdr (+ n 1) arglis))
    `(fn ,arglis
      (let dx (if (is ,x 0) 1d-9 (abs:* ,x 1d-9))
	(/ (- (,f ,@a-lis (+ ,x dx) ,@b-lis)
	      (,f ,@a-lis    ,x     ,@b-lis))
	   dx)))))

(mac partial-diff-vec (f n arity)
  "returns vector with each element differentiated with respect to Nth argument"
  (withs (arglis (n-of arity (uniq))
	  a-lis (firstn n arglis)
	  x arglis.n
	  b-lis (nthcdr (+ n 1) arglis))
    `(fn ,arglis
	(let dx (if (is ,x 0) 1d-9 (abs:* ,x 1d-9))
	   (vec-scale (vec- (,f ,@a-lis	(+ ,x dx) ,@b-lis)
			    (,f ,@a-lis    ,x     ,@b-lis))
		      (/ 1 dx))))))

(def grad (f)
  "gradient of 3D scalar field given by F"
  (fn (x y z)
    (list ((partial-diff f 0 3) x y z)
	  ((partial-diff f 1 3) x y z)
	  ((partial-diff f 2 3) x y z))))

(def div (f)
  "divergence of 3D vector field given by F"
  (fn (x y z)
      (+ (((partial-diff-vec f 0 3) x y z) 0)
	 (((partial-diff-vec f 1 3) x y z) 1)
	 (((partial-diff-vec f 2 3) x y z) 2))))

(def curl (f)
  "curl of 3D vector field given by F"
  (with (d/dx (partial-diff-vec f 0 3)
	 d/dy (partial-diff-vec f 1 3)
	 d/dz (partial-diff-vec f 2 3))
  (fn (x y z)
    (list (- ((d/dy x y z) 2)
	     ((d/dz x y z) 1))
	  (- ((d/dz x y z) 0)
	     ((d/dx x y z) 2))
	  (- ((d/dx x y z) 1)
	     ((d/dy x y z) 0))))))

(def integral (f)
  "returns the integral of a single argument function using Simpson's method"
  (fn (lower upper (o its 100))
    (withs (dx      (/ (- upper lower) its)
	    x       lower
	    current (f x)
	    next    (f (+ x dx))
	    accum   0)
      (while (<= x (- upper dx))
	     (++ accum (/ (+ (* (+ current next) 1/2 dx)
			     (* 2 dx (f (+ x (/ dx 2)))))
			  3))
	     (++ x dx)
	     (= current next)
	     (= next (f:+ x dx)))
      accum)))

(def adaptive-integral (f)
  (let int (memo:integral f)
       (afn (lower upper (o tol 0.001))
	    (with (a (int lower upper 2)
		   b (int lower upper 8))
	       (if (and (isnt b 0) (< (abs:/ (- a b) b) tol))
		   b
		   (let half (+ lower (/ (- upper lower) 2))
			(+ (self lower half tol) (self half upper tol))))))))

; vector fns

(def vec-dot (v1 v2)
  (apply + (map (fn (x y) (* x y)) v1 v2)))

(def vec-cross (v1 v2 . args)
  (if (car args)(vec-cross (vec-cross v1 v2) (car args) (cdr args))
                (list (- (* v1.1 v2.2) (* v2.1 v1.2))
		      (- (* v1.2 v2.0) (* v2.2 v1.0))
		      (- (* v1.0 v2.1) (* v2.0 v1.1)))))

(with (v+ (fn (v1 v2)
	     (map (fn (x y) (+ x y)) v1 v2))
       v- (fn (v1 v2)
	     (map (fn (x y) (- x y)) v1 v2)))

  (def vec+ (v1 . args)
    (if no.args v1
	(reduce v+ (cons v1 args))))

  (def vec- (v1 . args)
    (if no.args (map [- _] v1)
	(v- v1 (apply vec+ args))))
)

(def vec-scale (vec . scalars)
  (let c (apply * scalars)
    (map [* _ c] vec)))

(def quad-add args
  ((afn (tot xs)
     (if no.xs (sqrt tot)
	 (self (+ tot (expt (car xs) 2)) (cdr xs))))
   0 args))

(def vec-norm (vec)
  (vec-scale vec (/ (apply quad-add vec))))

;others

(def square (x) (* x x))
(def cube (x) (* x x x))
(def floor (n) (trunc n))
(def ceiling (n) (int ($.ceiling n)))
(def highbyte (n) (floor (/ n 256)))
(def lowbyte (n) (mod n 256))

(def fact (num)
  "factorial of num (num must be a fixnum)"
  (if (or (< num 0)(no:isa num 'int)) (err "num must be a positive integer")
      ((afn (n x)
	 (if (<= n 1)
	     x
	     (self (- n 1) (* n x))))
       num 1)))

(def n-bessel (n (o terms 100))
  "gives a fn for the nth bessel function of the first kind evaluated at x"
  (fn (x)
    (with (i 0
	   tot 0)
      (while (< i terms)
	     (++ tot (/ (* (expt -1 i) (expt (/ x 2) (+ n i i)))
			(* (fact i) (fact (+ n i)))))
	     (++ i 1))
      tot)))

(def mean lis
  ((afn (tot i x . xs)
     (if no.xs (/ (+ tot x) (+ i 1))
	 (self (+ tot x) (+ i 1) car.xs cdr.xs)))
   0 0 car.lis cdr.lis))

(def std-dev lis
  (let m mean.lis
    (sqrt:/ (apply + (map [expt (- _ m) 2] lis))
	    len.lis)))

(def choose (n x)
  "number of ways of picking n elements from x (ie no. of ways of mixing 2 different sets of identical objects of size n and (- x n))"
  (if (> n x)
      (do (prn "")(pr n)(pr " is greater than ")(prn x))
      (/ (fact x) (* (fact n) (fact (- x n))))))

(def gauss-random (sigma (o middle 0))
  "aproximation to a gausian distributed random with width sigma around middle, max possible deviation +/- 1000sigma"
  (let tot 0
    (for i 0 999
      (++ tot  (- (* (rand) 2.0) 1)))
    (+ (* tot (/ sigma 25)) middle)))

(def quad-roots (a b c)
  "returns roots of the equation ax^2+bx+c=0"
  (let sqroot (sqrt (- (* b b) (* 4 a c)))
    (if (is sqroot 0) (list (/ (- b) 2 a))
	(list (/ (- sqroot b) 2 a)
	      (/ (- 0 sqroot b) 2 a)))))


add extend-readtable

add extend-readtable

; lib/util.arc: A collection of useful miscellanea

; Contributors:
; - Michael Arntzenius <daekharel@gmail.com>

; Persons we've shamelessly ripped off:
; - Conan Dalton <conan@conandalton.net>
; - absz (http://arclanguage.org/user?id=absz)
; - fallintothis (http://arclanguage.org/user?id=fallintothis)

; License: Do what you want, but it's not my fault!
; This license applies to all code in this file UNLESS OTHERWISE NOTED.

; Feel free to make additions to this file and push them to anarki. Keep it to
; stuff that is widely applicable. Don't remove or change the semantics of stuff
; other people added. Add yourself to the contributors list above if you want.

; If you wish to use a different license, make a comment around the code you've
; contributed noting the license. No licenses that don't permit modification
; (duh) and redistribution (double duh).

; Try and keep track of what is whose in sections with unknown licenses
; ("ripoffs").

; miscellaneous

(def fst (a . _) " Returns its first argument. See also [[snd]] " a)
(def snd (a b . _) " Returns its second argument. See also [[fst]] " b)

(def bool (x)
  " Returns `t' if x is not nil, and `nil' otherwise. "
  (if x t))

(def uniqs (lst)
  " Returns a list of gensyms, one for each element of `lst'. Elements
    of `lst' that are symbols are used as the base names for their
    corresponding gensyms.
    See also [[uniq]] "
  (map1 (iff asym uniq [uniq]) lst))

(def gc () ($.collect-garbage))

; type checkers
(def asym (x) " `t' iff `x' is a symbol. " (isa x 'sym))
(def astring (x) " `t' iff `x' is a string. " (isa x 'string))
(def atable (x) " `t' iff `x' is a table. " (isa x 'table))
(def aint (x) " `t' iff `x' is an int. " (isa x 'int))
(def anum (x) " `t' iff `x' is a num. Note that ints are not nums. "
  (isa x 'num))

; list manipulation

; 'reduce and 'rreduce have somewhat quirky behavior, well-suited to arithmetic
; functions, but otherwise hard to reason about. I usually prefer 'foldl and
; 'foldr.
(def foldl (f v l)
  (if l (foldl f (f v car.l) cdr.l) v))

(def foldr (f v l)
  (foldl flip.f v rev.l))

(def foot (l)
  " Gets the last cons in a proper list. (Fails on dotted lists.) "
  (aif cdr.l foot.it l))

(def join/d ls
  " Destructive join.
    See also [[join]]"
  (foldr (afn (a b) (if b (aif foot.a (do (scdr it b) a) b) a)) nil ls))

(def classify (classifier seq)
  " Groups the elements of `seq' by `classifier', returning back a table,
    whose keys are the results of `classifier' and whose values are lists
    of the corresponding elements of `seq'. For example:

      arc> (classify type '(1 \"foo\" a 2 (b)))
      #hash((cons . ((b))) (int . (2 1)) (string . (\"foo\")) (sym . (a)))

    See also [[partition]] [[keep]] [[rem]] "
  (w/table h
    (each e seq
      (push e (h classifier.e)))))

(def partition (test seq)
  " Equivalent to but more efficient than
   `(list (keep test seq) (rem test seq))'. See also [[keep]] [[rem]] "
  (let (passed failed) nil
    (each e seq
      (if test.e
        (push e passed)
        (push e failed)))
    (list rev.passed rev.failed)))

(def unzip (xs)
  " Precisely as `zip', except that zip's `ls' is unzip's `xs'; so it takes one
    list of lists rather than any number of lists as arguments. Can be thought
    of as performing the inverse operation.
    See also [[zip]] "
  (apply map list xs))

(def zip ls
  " Returns a list of lists; the n-th element of the result is a list of the
    n-th elements of the lists in `ls'. The length of the result is the length
    of the shortest list in `ls'; extra elements in other lists are discarded.
    See also [[unzip]] "
  (unzip ls))

(def mklist (x)
  " Wraps atoms in a list; does nothing if `x' is already a list.
    See also [[atom]] [[alist]] [[list]] "
  (check x alist list.x))

; 'many was precisely the same function as 'acons, hence has been removed (any
; cons has a length > 0, since nil is not a cons). Also, 'popfind has been
; renamed 'pull1, to fit with the newly-added 'rem1.

(def rem1 (test seq)
  " Returns a copy of `seq' with the first element that passes `test' removed.
    See also [[rem]] [[keep]] [[pull1]] [[pull]] "
  (zap testify test)
  (if alist.seq ((afn (s)
                   (if no.s nil
                       (f car.s) cdr.s
                       (cons car.s (self cdr.s))))
                 seq)
      (coerce (rem1 test (coerce seq 'cons)) 'string)))

(mac pull1 (test place)
  " Removes the first element that passes `test' from `place'.
    See also [[pull]] [[rem1]] [[rem]] [[keep]] "
  `(= ,place (rem1 ,test ,place)))

(def butlast (x)
  " Returns a list containing every element of `x' but the last.
    See also: [[cut]] "
  (cut x 0 (- (len x) 1)))

(= len= [is len._a _b])
(= len- [- len._a _b])
(= car< [< car._a car._b])
(= cdar cdr:car)
(= cadar car:cdar)
(= mapcar [map car _])
(= mapcdr [map cdr _])

(def keepkey (key lst) (keep [_ key] lst))
(def mapkey (key lst) (map [_ key] lst))

(def rand-pos (lst) (if lst (rand:len lst)))

(mac pushend (elem lst)
  `(= ,lst (join ,lst (list ,elem))))

(mac popnth (lst n)
  (w/uniq g1
    `(let ,g1 (,lst ,n)
       (= ,lst (+ (cut ,lst 0 ,n) (cut ,lst (+ 1 ,n))))
       ,g1)))

(mac poprand (lst)
  (w/uniq g1
    `(if ,lst
	 (let ,g1 (rand-pos ,lst)
	   (popnth ,lst ,g1)))))

; combinators

(def applied (f)
  " Returns a fn that calls `f' on the list of its arguments.
    For example, 'max is equivalent to `(applied [best > _])'. "
  (fn a (f a)))

(def flip (f)
  " Flips the order of the first two arguments of `f'.
    For example: ((flip cons) 1 2) => (2 . 1) "
  (fn (x y . zs) (apply f y x zs)))

(def curry (f . xs)
  " Partially applies (\"curries\") `f' to `xs'. "
  (fn ys (apply f (join xs ys))))

(def const (x)
  " Creates a fn that takes any number of arguments and returns `x'. "
  (fn _ x))

(def tfn _ " Ignores its arguments and returns t. " t)
(def nilfn _ " Ignores its arguments and returns nil. " nil)

(def norf fns
  " Creates a function which returns `t' iff none of `fns' return `t'
    on its arguments.
    See also [[orf]] [[andf]] [[nor]] "
  (complement (apply orf fns)))

(def iff funs
  " Put simply: iff is to if as andf is to and. Specifically:

    (iff) => idfn
    (iff fun) => fun
    (iff test fun rest ...) => a fn that applies `fun' to its arguments if they
    pass `test', otherwise applies `(iff rest...)' to them.

    Examples:

      arc> ((iff alist car) '(x))
      x
      arc> ((iff alist car) 2)
      2
      arc> ((iff < (fn (x y) x) (fn (x y) y)) 1 2)
      1

    See also [[andf]] [[orf]] [[check]] [[idfn]] "
  (case len.funs
    0 idfn
    1 funs.0
      (withs ((test fun . rest) funs
              restfun (apply iff rest))
        (fn a (if (apply test a) (apply fun a)
                  (apply restfun a))))))

; macros

(mac mapeach (var lst . body)
  " Maps `(fn (,var) ,@body)' over `lst'.
    See also [[each]] [[map]] [[mappendeach]] "
  `(map (fn (,var) ,@body) ,lst))

(mac mappendeach (var lst . body)
  " As 'mapeach, but using 'mappend instead of 'map.
    See also [[mapeach]] [[mappend]] [[each]] "
  `(mappend (fn (,var) ,@body) ,lst))

(mac ado body
  " Anaphoric do.
    See also [[aif]] [[awhen]] [[aand]] "
  (aif cdr.body `(let it ,car.body (ado ,@it))
       car.body))

; now that pg has renamed 'assert to 'set, we're free to use it in its more
; conventional sense
(mac assert (exp (o msg (+ "Assertion failed: "
                           (tostring:ppr exp (len "Assertion failed: ") t))))
  " Errors with `msg' if `exp' evaluates to nil. "
  `(unless ,exp (err ,msg)))

(mac asserts args
  " Asserts each expr in `args', with the default error message. "
  `(do ,@(map [list 'assert _] args)))

(mac switchlet (var expr . cases)
  " Like 'caselet, except it (lazily) evals the expressions compared against.
    See also [[switch]] [[caselet]] [[case]]"
  `(let ,var ,expr
     ,((afn (args)
         (if (no cdr.args) car.args
           `(if (is ,var ,car.args) ,cadr.args
              ,(self cddr.args)))) cases)))

(mac switch (expr . cases)
  " 'switch is to 'switchlet as 'case is to 'caselet.
    See also [[switchlet]] [[case]] [[caselet]]"
  `(switchlet ,(uniq) ,exp ,@cases))

(mac dol (parms (test result) . body)
  " Like the standard lisp/scheme do loop, but with redundant inner parens
    removed."
  (w/uniq loop-name
    (let parms (tuples parms 3)
      `((rfn ,loop-name ,(map1 [_ 0] parms)
          (if ,test ,result
            (do ,@body (,loop-name ,@(map1 [_ 2] parms)))))
         ,@(map1 [_ 1] parms)))))

(mac w/stdoutfile (name . body)
  " Redirects stdout to the file `name' within `body'.
    See also [[w/stdinfile]] [[w/outfile]] [[w/stdout]] "
  (w/uniq str `(w/outfile ,str ,name (w/stdout ,str ,@body))))

(mac w/stdinfile (name . body)
  " Redirects standard input from the file `name' within `body'.
    See also [[w/stdoutfile]] [[w/infile]] [[w/stdin]] "
  (w/uniq str `(w/infile ,str ,name (w/stdin ,str ,@body))))

; binding forms

(mac with/p (vars-vals . body)
  " Scheme/Common Lisp's `let' - ie: 'with with the parens added back.
    Easier to use in macro expansions than 'with.
    See also [[with]] [[withs/p]] "
  `(with ,(apply join vars-vals) ,@body))

(mac withs/p (vars-vals . body)
  " Like Scheme/Common Lisp's `let*' - ie: 'withs with the parens added back.
    Easier to use in macro expansions than 'withs.
    See also [[withs]] [[with/p]] "
  `(withs ,(apply join vars-vals) ,@body))

; a 'with that works for defining recursive fns
(mac withr/p (bindings . body)
  " Scheme's 'letrec.
    See also [[withr]] [[where]] "
  `(let ,(map1 car bindings) nil
     ,@(map [cons 'assign _] bindings)
     ,@body))

(mac withr (bindings . body)
  " Scheme's 'letrec, with the redundant inner parens removed.
    See also [[withf]] [[letf]] [[where]] [[withr/p]] "
  `(withr/p ,pair.bindings ,@body))

; mutually recursive local fns
(mac withf/p (fns . body)
  " Like 'withf, only with extra parens, as in 'with/p compared to 'with.
    See also [[withf]] [[with/p]] [[withr]] [[withr/p]] "
  `(withr/p ,(mapeach (name . rest) fns `(,name (fn ,@rest)))
     ,@body))

(mac withf (fns . body)
  " Defines a set `fns' of mutually recursive local fns within `body'. Each
    three elements of `fn' correspond to a fn name, argument list, and body,
    so you'll need to use 'do if you want a multi-expression fn body.
    Example:

      arc> (withf (is-even (x) (case x 0 t (is-odd (- x 1)))
                   is-odd (x) (case x 0 nil (is-even (- x 1))))
             (keep is-odd (range 0 5)))
      (1 3 5)

    See also [[letf]] [[withr]] "
  `(withf/p ,(tuples fns 3) ,@body))

(mac letf (name args expr . body)
  " Defines a (possibly recursive) local fn `(fn ,args ,expr)' named `name'
    within `body'. Example:

      arc> (letf last (x) (aif cdr.x last.it car.x)
             (last '(x y z)))
      z

    See also [[withf]] [[withr]] "
  `(withf (,name ,args ,expr) ,@body))

; inspired by Haskell
(mac where (expr . parms)
  " Binds `parms' and evaluates `expr'. Examples:

      arc> (where (square x)
              square [* _ _]
              x 2)
      4

    Note that binding is recursive, but that actual assignment of values is done
    in the reverse of the order given, so any variables which are both bound and
    used in `parms' must be used in reverse dependency order:

      arc> (where x x (+ y y) y 0)    ; this works as expected
      y
      arc> (where x y 0 x (+ y y))    ; this doesn't
      nil

    Essentially, this is a reversed form of Scheme's 'letrec,
    with many fewer parentheses. Inspired by Haskell's \"where\".
    See also [[withr]] [[withr/p]] [[withf]] "
  `(withr/p ,(rev:pair parms) ,expr))

; ripoffs - licenses unknown

; once-only by fallintothis
; http://arclanguage.org/item?id=9939
; CHANGED 2009-08-20:
;   + take advantage of 'uniqs, 'with/p, 'zip
;   + wrap 'names in a list if it's an atom
;   + alter indentation slightly
;  - Michael Arntzenius

(mac once-only (names . body)
  (withs (names (check names alist list.names)
          gensyms (uniqs names))
    `(w/uniq ,gensyms
       `(with ,(list ,@(mappend list gensyms names))
          ,(with/p ,(zip names gensyms)
             ,@body)))))

; afnwith by Conan Dalton
; http://arclanguage.org/item?id=10055
; CHANGED 2009-08-15: added docstrings - Michael Arntzenius
(mac rfnwith (name withses . body)
  " Convenient wrapper for applying an rfn using with-like syntax.
    `withses' is a list of argument names and their initial values.
    Best explained by example:

      arc> (rfnwith sum (x (range 1 3))
             (iflet (a . r) x (+ a (sum r)) 0))
      6

    The above example macroexpands to:

      ((rfn sum (x) (iflet (a . r) x (+ a (sum r)) 0))
       (range 1 3))

    See also [[afnwith]] [[w/rfn]] [[rfn]] "
  (let w (pair withses)
    `((rfn ,name ,(map car w) ,@body) ,@(map cadr w))))

(mac afnwith (withses . body)
  " Convenient wrapper for applying an afn using with-like syntax.
    `withses' is a list of argument names and their initial values.
    Best explained by example:

      arc> (afnwith (x (range 1 3))
             (iflet (a . r) x (+ a (self r)) 0))
      6

    See also [[rfnwith]] [[w/afn]] [[afn]] "
  `(rfnwith self ,withses ,@body))

; ripoff: w/afn, by absz
; http://arclanguage.org/item?id=10125
; CHANGED 2009-08-15: added docstrings - Michael Arntzenius

(mac w/rfn (name withses . body)
  " Convenient wrapper for applying an rfn using preexisting variables
    in `withses' as arguments. Best explained by example:

      arc> (let x (range 1 3)
             (w/rfn sum (x)
               (iflet (a . r) x (+ a (sum r)) 0)))
      6

    The above example (w/rfn sum ...) macroexpands to:

      ((rfn sum (x) (iflet (a . r) x (+ a (sum r)) 0))
       x)

    See also [[w/afn]] [[rfnwith]] [[rfn]] "
  `(rfnwith ,name ,(mappend [list _ _] mklist.withses) ,@body))

(mac w/afn (withses . body)
  " Convenient wrapper for applying an afn using the preexisting variables
    in `withses' as arguments. Best explained by example:

      arc> (let x (range 1 3)
             (w/afn (x)
               (iflet (a . r) x (+ a (self r)) 0)))
      6

    The above example (w/afn (x) ...) macroexpands to:

      ((afn (x) (iflet (a . r) x (+ a (sum r)) 0))
       x)

    See also [[w/rfn]] [[afnwith]] [[afn]] "
  `(w/rfn self ,withses ,@body))

; ripoff: between, by Andrew Wilcox
; http://awwx.ws/between
; CHANGED 2010-01-02:
;   + added docstrings - Michael Arntzenius
;   + only wipe first on the first run through
;  - Michael Arntzenius

(mac between (var expr within . body)
  " As 'each, but runs `within' between each iteration of `body'.
    See also [[each]] "
  (w/uniq first
    `(let ,first t
       (each ,var ,expr
         (unless ,first
           ,within
           (wipe ,first))
         ,@body))))

; start Andrew Wilcox (aw) code

; http://awwx.ws/xloop0.arc
(mac xloop (withses . body)
  (let w (pair withses)
      `((rfn next ,(map car w) ,@body) ,@(map cadr w))))

; http://awwx.ws/implicit2.arc
(mac implicit (name (o val))
  `(do (defvar ,name ($.make-parameter ,val))
       (mac ,(sym (string "w/" name)) (v . body)
         (w/uniq (param gv gf)
           `(with (,param (defvar-impl ,',name)
                   ,gv ,v
                   ,gf (fn () ,@body))
              ($ (parameterize ((,param ,gv)) (,gf))))))))

; http://awwx.ws/extend-readtable0.arc
(def extend-readtable (c parser)
  ($
   (current-readtable
    (make-readtable (current-readtable)
                    c
                    'non-terminating-macro
                    (lambda (ch port src line col pos)
                      (parser port))))))

; end aw code

; ripoff: ret, by skenney26
; http://github.com/skenney26/kwizwiz/blob/master/kwizwiz.arc

(mac ret (var val . body)
  `(let ,var ,val ,@body ,var))

; END RIPOFFS

; lib/util.arc: A collection of useful miscellanea

; Contributors:
; - Michael Arntzenius <daekharel@gmail.com>

; Persons we've shamelessly ripped off:
; - Conan Dalton <conan@conandalton.net>
; - absz (http://arclanguage.org/user?id=absz)
; - fallintothis (http://arclanguage.org/user?id=fallintothis)

; License: Do what you want, but it's not my fault!
; This license applies to all code in this file UNLESS OTHERWISE NOTED.

; Feel free to make additions to this file and push them to anarki. Keep it to
; stuff that is widely applicable. Don't remove or change the semantics of stuff
; other people added. Add yourself to the contributors list above if you want.

; If you wish to use a different license, make a comment around the code you've
; contributed noting the license. No licenses that don't permit modification
; (duh) and redistribution (double duh).

; Try and keep track of what is whose in sections with unknown licenses
; ("ripoffs").

; miscellaneous

(def fst (a . _) " Returns its first argument. See also [[snd]] " a)
(def snd (a b . _) " Returns its second argument. See also [[fst]] " b)

(def bool (x)
  " Returns `t' if x is not nil, and `nil' otherwise. "
  (if x t))

(def uniqs (lst)
  " Returns a list of gensyms, one for each element of `lst'. Elements
    of `lst' that are symbols are used as the base names for their
    corresponding gensyms.
    See also [[uniq]] "
  (map1 (iff asym uniq [uniq]) lst))

(def gc () ($.collect-garbage))

; type checkers
(def asym (x) " `t' iff `x' is a symbol. " (isa x 'sym))
(def astring (x) " `t' iff `x' is a string. " (isa x 'string))
(def atable (x) " `t' iff `x' is a table. " (isa x 'table))
(def aint (x) " `t' iff `x' is an int. " (isa x 'int))
(def anum (x) " `t' iff `x' is a num. Note that ints are not nums. "
  (isa x 'num))

; list manipulation

; 'reduce and 'rreduce have somewhat quirky behavior, well-suited to arithmetic
; functions, but otherwise hard to reason about. I usually prefer 'foldl and
; 'foldr.
(def foldl (f v l)
  (if l (foldl f (f v car.l) cdr.l) v))

(def foldr (f v l)
  (foldl flip.f v rev.l))

(def foot (l)
  " Gets the last cons in a proper list. (Fails on dotted lists.) "
  (aif cdr.l foot.it l))

(def join/d ls
  " Destructive join.
    See also [[join]]"
  (foldr (afn (a b) (if b (aif foot.a (do (scdr it b) a) b) a)) nil ls))

(def classify (classifier seq)
  " Groups the elements of `seq' by `classifier', returning back a table,
    whose keys are the results of `classifier' and whose values are lists
    of the corresponding elements of `seq'. For example:

      arc> (classify type '(1 \"foo\" a 2 (b)))
      #hash((cons . ((b))) (int . (2 1)) (string . (\"foo\")) (sym . (a)))

    See also [[partition]] [[keep]] [[rem]] "
  (w/table h
    (each e seq
      (push e (h classifier.e)))))

(def partition (test seq)
  " Equivalent to but more efficient than
   `(list (keep test seq) (rem test seq))'. See also [[keep]] [[rem]] "
  (let (passed failed) nil
    (each e seq
      (if test.e
        (push e passed)
        (push e failed)))
    (list rev.passed rev.failed)))

(def unzip (xs)
  " Precisely as `zip', except that zip's `ls' is unzip's `xs'; so it takes one
    list of lists rather than any number of lists as arguments. Can be thought
    of as performing the inverse operation.
    See also [[zip]] "
  (apply map list xs))

(def zip ls
  " Returns a list of lists; the n-th element of the result is a list of the
    n-th elements of the lists in `ls'. The length of the result is the length
    of the shortest list in `ls'; extra elements in other lists are discarded.
    See also [[unzip]] "
  (unzip ls))

(def mklist (x)
  " Wraps atoms in a list; does nothing if `x' is already a list.
    See also [[atom]] [[alist]] [[list]] "
  (check x alist list.x))

; 'many was precisely the same function as 'acons, hence has been removed (any
; cons has a length > 0, since nil is not a cons). Also, 'popfind has been
; renamed 'pull1, to fit with the newly-added 'rem1.

(def rem1 (test seq)
  " Returns a copy of `seq' with the first element that passes `test' removed.
    See also [[rem]] [[keep]] [[pull1]] [[pull]] "
  (zap testify test)
  (if alist.seq ((afn (s)
                   (if no.s nil
                       (f car.s) cdr.s
                       (cons car.s (self cdr.s))))
                 seq)
      (coerce (rem1 test (coerce seq 'cons)) 'string)))

(mac pull1 (test place)
  " Removes the first element that passes `test' from `place'.
    See also [[pull]] [[rem1]] [[rem]] [[keep]] "
  `(= ,place (rem1 ,test ,place)))

(def butlast (x)
  " Returns a list containing every element of `x' but the last.
    See also: [[cut]] "
  (cut x 0 (- (len x) 1)))

(= len= [is len._a _b])
(= len- [- len._a _b])
(= car< [< car._a car._b])
(= cdar cdr:car)
(= cadar car:cdar)
(= mapcar [map car _])
(= mapcdr [map cdr _])

(def keepkey (key lst) (keep [_ key] lst))
(def mapkey (key lst) (map [_ key] lst))

(def rand-pos (lst) (if lst (rand:len lst)))

(mac pushend (elem lst)
  `(= ,lst (join ,lst (list ,elem))))

(mac popnth (lst n)
  (w/uniq g1
    `(let ,g1 (,lst ,n)
       (= ,lst (+ (cut ,lst 0 ,n) (cut ,lst (+ 1 ,n))))
       ,g1)))

(mac poprand (lst)
  (w/uniq g1
    `(if ,lst
	 (let ,g1 (rand-pos ,lst)
	   (popnth ,lst ,g1)))))

; combinators

(def applied (f)
  " Returns a fn that calls `f' on the list of its arguments.
    For example, 'max is equivalent to `(applied [best > _])'. "
  (fn a (f a)))

(def flip (f)
  " Flips the order of the first two arguments of `f'.
    For example: ((flip cons) 1 2) => (2 . 1) "
  (fn (x y . zs) (apply f y x zs)))

(def curry (f . xs)
  " Partially applies (\"curries\") `f' to `xs'. "
  (fn ys (apply f (join xs ys))))

(def const (x)
  " Creates a fn that takes any number of arguments and returns `x'. "
  (fn _ x))

(def tfn _ " Ignores its arguments and returns t. " t)
(def nilfn _ " Ignores its arguments and returns nil. " nil)

(def norf fns
  " Creates a function which returns `t' iff none of `fns' return `t'
    on its arguments.
    See also [[orf]] [[andf]] [[nor]] "
  (complement (apply orf fns)))

(def iff funs
  " Put simply: iff is to if as andf is to and. Specifically:

    (iff) => idfn
    (iff fun) => fun
    (iff test fun rest ...) => a fn that applies `fun' to its arguments if they
    pass `test', otherwise applies `(iff rest...)' to them.

    Examples:

      arc> ((iff alist car) '(x))
      x
      arc> ((iff alist car) 2)
      2
      arc> ((iff < (fn (x y) x) (fn (x y) y)) 1 2)
      1

    See also [[andf]] [[orf]] [[check]] [[idfn]] "
  (case len.funs
    0 idfn
    1 funs.0
      (withs ((test fun . rest) funs
              restfun (apply iff rest))
        (fn a (if (apply test a) (apply fun a)
                  (apply restfun a))))))

; macros

(mac mapeach (var lst . body)
  " Maps `(fn (,var) ,@body)' over `lst'.
    See also [[each]] [[map]] [[mappendeach]] "
  `(map (fn (,var) ,@body) ,lst))

(mac mappendeach (var lst . body)
  " As 'mapeach, but using 'mappend instead of 'map.
    See also [[mapeach]] [[mappend]] [[each]] "
  `(mappend (fn (,var) ,@body) ,lst))

(mac ado body
  " Anaphoric do.
    See also [[aif]] [[awhen]] [[aand]] "
  (aif cdr.body `(let it ,car.body (ado ,@it))
       car.body))

; now that pg has renamed 'assert to 'set, we're free to use it in its more
; conventional sense
(mac assert (exp (o msg (+ "Assertion failed: "
                           (tostring:ppr exp (len "Assertion failed: ") t))))
  " Errors with `msg' if `exp' evaluates to nil. "
  `(unless ,exp (err ,msg)))

(mac asserts args
  " Asserts each expr in `args', with the default error message. "
  `(do ,@(map [list 'assert _] args)))

(mac switchlet (var expr . cases)
  " Like 'caselet, except it (lazily) evals the expressions compared against.
    See also [[switch]] [[caselet]] [[case]]"
  `(let ,var ,expr
     ,((afn (args)
         (if (no cdr.args) car.args
           `(if (is ,var ,car.args) ,cadr.args
              ,(self cddr.args)))) cases)))

(mac switch (expr . cases)
  " 'switch is to 'switchlet as 'case is to 'caselet.
    See also [[switchlet]] [[case]] [[caselet]]"
  `(switchlet ,(uniq) ,exp ,@cases))

(mac dol (parms (test result) . body)
  " Like the standard lisp/scheme do loop, but with redundant inner parens
    removed."
  (w/uniq loop-name
    (let parms (tuples parms 3)
      `((rfn ,loop-name ,(map1 [_ 0] parms)
          (if ,test ,result
            (do ,@body (,loop-name ,@(map1 [_ 2] parms)))))
         ,@(map1 [_ 1] parms)))))

(mac w/stdoutfile (name . body)
  " Redirects stdout to the file `name' within `body'.
    See also [[w/stdinfile]] [[w/outfile]] [[w/stdout]] "
  (w/uniq str `(w/outfile ,str ,name (w/stdout ,str ,@body))))

(mac w/stdinfile (name . body)
  " Redirects standard input from the file `name' within `body'.
    See also [[w/stdoutfile]] [[w/infile]] [[w/stdin]] "
  (w/uniq str `(w/infile ,str ,name (w/stdin ,str ,@body))))

; binding forms

(mac with/p (vars-vals . body)
  " Scheme/Common Lisp's `let' - ie: 'with with the parens added back.
    Easier to use in macro expansions than 'with.
    See also [[with]] [[withs/p]] "
  `(with ,(apply join vars-vals) ,@body))

(mac withs/p (vars-vals . body)
  " Like Scheme/Common Lisp's `let*' - ie: 'withs with the parens added back.
    Easier to use in macro expansions than 'withs.
    See also [[withs]] [[with/p]] "
  `(withs ,(apply join vars-vals) ,@body))

; a 'with that works for defining recursive fns
(mac withr/p (bindings . body)
  " Scheme's 'letrec.
    See also [[withr]] [[where]] "
  `(let ,(map1 car bindings) nil
     ,@(map [cons 'assign _] bindings)
     ,@body))

(mac withr (bindings . body)
  " Scheme's 'letrec, with the redundant inner parens removed.
    See also [[withf]] [[letf]] [[where]] [[withr/p]] "
  `(withr/p ,pair.bindings ,@body))

; mutually recursive local fns
(mac withf/p (fns . body)
  " Like 'withf, only with extra parens, as in 'with/p compared to 'with.
    See also [[withf]] [[with/p]] [[withr]] [[withr/p]] "
  `(withr/p ,(mapeach (name . rest) fns `(,name (fn ,@rest)))
     ,@body))

(mac withf (fns . body)
  " Defines a set `fns' of mutually recursive local fns within `body'. Each
    three elements of `fn' correspond to a fn name, argument list, and body,
    so you'll need to use 'do if you want a multi-expression fn body.
    Example:

      arc> (withf (is-even (x) (case x 0 t (is-odd (- x 1)))
                   is-odd (x) (case x 0 nil (is-even (- x 1))))
             (keep is-odd (range 0 5)))
      (1 3 5)

    See also [[letf]] [[withr]] "
  `(withf/p ,(tuples fns 3) ,@body))

(mac letf (name args expr . body)
  " Defines a (possibly recursive) local fn `(fn ,args ,expr)' named `name'
    within `body'. Example:

      arc> (letf last (x) (aif cdr.x last.it car.x)
             (last '(x y z)))
      z

    See also [[withf]] [[withr]] "
  `(withf (,name ,args ,expr) ,@body))

; inspired by Haskell
(mac where (expr . parms)
  " Binds `parms' and evaluates `expr'. Examples:

      arc> (where (square x)
              square [* _ _]
              x 2)
      4

    Note that binding is recursive, but that actual assignment of values is done
    in the reverse of the order given, so any variables which are both bound and
    used in `parms' must be used in reverse dependency order:

      arc> (where x x (+ y y) y 0)    ; this works as expected
      y
      arc> (where x y 0 x (+ y y))    ; this doesn't
      nil

    Essentially, this is a reversed form of Scheme's 'letrec,
    with many fewer parentheses. Inspired by Haskell's \"where\".
    See also [[withr]] [[withr/p]] [[withf]] "
  `(withr/p ,(rev:pair parms) ,expr))

; ripoffs - licenses unknown

; once-only by fallintothis
; http://arclanguage.org/item?id=9939
; CHANGED 2009-08-20:
;   + take advantage of 'uniqs, 'with/p, 'zip
;   + wrap 'names in a list if it's an atom
;   + alter indentation slightly
;  - Michael Arntzenius

(mac once-only (names . body)
  (withs (names (check names alist list.names)
          gensyms (uniqs names))
    `(w/uniq ,gensyms
       `(with ,(list ,@(mappend list gensyms names))
          ,(with/p ,(zip names gensyms)
             ,@body)))))

; afnwith by Conan Dalton
; http://arclanguage.org/item?id=10055
; CHANGED 2009-08-15: added docstrings - Michael Arntzenius
(mac rfnwith (name withses . body)
  " Convenient wrapper for applying an rfn using with-like syntax.
    `withses' is a list of argument names and their initial values.
    Best explained by example:

      arc> (rfnwith sum (x (range 1 3))
             (iflet (a . r) x (+ a (sum r)) 0))
      6

    The above example macroexpands to:

      ((rfn sum (x) (iflet (a . r) x (+ a (sum r)) 0))
       (range 1 3))

    See also [[afnwith]] [[w/rfn]] [[rfn]] "
  (let w (pair withses)
    `((rfn ,name ,(map car w) ,@body) ,@(map cadr w))))

(mac afnwith (withses . body)
  " Convenient wrapper for applying an afn using with-like syntax.
    `withses' is a list of argument names and their initial values.
    Best explained by example:

      arc> (afnwith (x (range 1 3))
             (iflet (a . r) x (+ a (self r)) 0))
      6

    See also [[rfnwith]] [[w/afn]] [[afn]] "
  `(rfnwith self ,withses ,@body))

; ripoff: w/afn, by absz
; http://arclanguage.org/item?id=10125
; CHANGED 2009-08-15: added docstrings - Michael Arntzenius

(mac w/rfn (name withses . body)
  " Convenient wrapper for applying an rfn using preexisting variables
    in `withses' as arguments. Best explained by example:

      arc> (let x (range 1 3)
             (w/rfn sum (x)
               (iflet (a . r) x (+ a (sum r)) 0)))
      6

    The above example (w/rfn sum ...) macroexpands to:

      ((rfn sum (x) (iflet (a . r) x (+ a (sum r)) 0))
       x)

    See also [[w/afn]] [[rfnwith]] [[rfn]] "
  `(rfnwith ,name ,(mappend [list _ _] mklist.withses) ,@body))

(mac w/afn (withses . body)
  " Convenient wrapper for applying an afn using the preexisting variables
    in `withses' as arguments. Best explained by example:

      arc> (let x (range 1 3)
             (w/afn (x)
               (iflet (a . r) x (+ a (self r)) 0)))
      6

    The above example (w/afn (x) ...) macroexpands to:

      ((afn (x) (iflet (a . r) x (+ a (sum r)) 0))
       x)

    See also [[w/rfn]] [[afnwith]] [[afn]] "
  `(w/rfn self ,withses ,@body))

; ripoff: between, by Andrew Wilcox
; http://awwx.ws/between
; CHANGED 2010-01-02:
;   + added docstrings - Michael Arntzenius
;   + only wipe first on the first run through
;  - Michael Arntzenius

(mac between (var expr within . body)
  " As 'each, but runs `within' between each iteration of `body'.
    See also [[each]] "
  (w/uniq first
    `(let ,first t
       (each ,var ,expr
         (unless ,first
           ,within
           (wipe ,first))
         ,@body))))

; Andrew Wilcox henceforth aw

; xloop by aw
(mac xloop (withses . body)
  (let w (pair withses)
      `((rfn next ,(map car w) ,@body) ,@(map cadr w))))

; http://awwx.ws/implicit2.arc
(mac implicit (name (o val))
  `(do (defvar ,name ($.make-parameter ,val))
       (mac ,(sym (string "w/" name)) (v . body)
         (w/uniq (param gv gf)
           `(with (,param (defvar-impl ,',name)
                   ,gv ,v
                   ,gf (fn () ,@body))
              ($ (parameterize ((,param ,gv)) (,gf))))))))

; ripoff: ret, by skenney26
; http://github.com/skenney26/kwizwiz/blob/master/kwizwiz.arc

(mac ret (var val . body)
  `(let ,var ,val ,@body ,var))

; END RIPOFFS


Define UNESCHTML and UNESC-TAGS

Define UNESCHTML and UNESC-TAGS

; 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 #\<  "<"
                #\>  ">"
                #\"  """
                #\&  "&"
                c))))

(attribute a          href           opstring)
(attribute a          rel            opstring)
(attribute a          class          opstring)
(attribute a          id             opsym)
(attribute a          onclick        opstring)
(attribute div        class          opstring)
(attribute div        id             opsym)
(attribute div        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 table      id             opsym)
(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 "")
                (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 "
"))
  (prn))

(def br2 () (prn "

"))

(mac center    body         `(tag center ,@body))
(mac underline body         `(tag u ,@body))
(mac idtab     (id . body)  `(tag (table border 0 id ,id) ,@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 ""))
      `(pr "")))

;(def spacerow (h) (tr (td (vspace h))))

(def spacerow (h) (pr "

"))

; For use as nested table.

(mac zerotable body
  `(tag (table border 0 cellpadding 1 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 " ")))

(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 #\<  "<"
                  #\>  ">"
                  #\"  """
                  #\'  "'"
                  #\&  "&"
                        c)))))

(def uneschtml (str)
  (multisubst
    '(("<" "<")
      (">" ">")
      (""" "\"")
      ("'" "'")
      ("&" "&"))
    str))

(def esc-tags (str)
  (tostring
    (each c str
      (pr (case c #\<  "<"
                  #\>  ">"
                  #\&  "&"
                        c)))))

(def unesc-tags (str)
  (multisubst
    '(("<" "<")
      (">" ">")
      ("&" "&"))
    str))

(def nbsp () (pr " "))

(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 "
"))
          (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)))))

; 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 #\<  "<"
                #\>  ">"
                #\"  """
                #\&  "&"
                c))))

(attribute a          href           opstring)
(attribute a          rel            opstring)
(attribute a          class          opstring)
(attribute a          id             opsym)
(attribute a          onclick        opstring)
(attribute div        class          opstring)
(attribute div        id             opsym)
(attribute div        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 table      id             opsym)
(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 "")
                (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 "
"))
  (prn))

(def br2 () (prn "

"))

(mac center    body         `(tag center ,@body))
(mac underline body         `(tag u ,@body))
(mac idtab     (id . body)  `(tag (table border 0 id ,id) ,@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 ""))
      `(pr "")))

;(def spacerow (h) (tr (td (vspace h))))

(def spacerow (h) (pr "

"))

; For use as nested table.

(mac zerotable body
  `(tag (table border 0 cellpadding 1 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 " ")))

(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 #\<  "<"
                  #\>  ">"
                  #\"  """
                  #\'  "'"
                  #\&  "&"
                        c)))))

(def esc-tags (str)
  (tostring
    (each c str
      (pr (case c #\<  "<"
                  #\>  ">"
                  #\&  "&"
                        c)))))

(def nbsp () (pr " "))

(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 "
"))
          (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)))))


load news.arc by default; I'm missing bugs there

(map load '("lib/require.arc"
            "lib/extend.arc"
            "lib/strings.arc"
            "lib/tem.arc"
            "lib/util.arc"
            "lib/declare.arc"
            "lib/make-br-fn.arc"

            ; webserver stuff
            "lib/html.arc"
            "lib/srv.arc"
            "lib/app.arc"
            "lib/news.arc"

            ; helpers for the repl
            "lib/arctap.arc"
            "lib/ppr.arc"
            "lib/help.arc"
          ))

(map load '("lib/require.arc"
            "lib/extend.arc"
            "lib/strings.arc"
            "lib/tem.arc"
            "lib/util.arc"
            "lib/declare.arc"
            "lib/make-br-fn.arc"

            ; webserver stuff
            "lib/html.arc"
            "lib/srv.arc"
            "lib/app.arc"

            ; helpers for the repl
            "lib/arctap.arc"
            "lib/ppr.arc"
            "lib/help.arc"
          ))