; Built-in things in LISP instead of C


; First make defmacro and defun so we can use them in the rest.

(define defmacro (macro (name vars body) (define name (macro vars body))))

(defmacro defun (name vars body) (define name (lambda vars body)))


; The order that define/defmacro/defun calls appear in this file
; doesn't really matter, since they can refer to other definitions both
; before and after they appear. For non-definition calls, such as
; (doc) and (sprintf-add), order does matter - they can only use
; things previously defined.


; Define doc so that we can use it on the rest.

(defun err ("string" fmtstr . args)
    (err-make (sprintf fmtstr . args))
)

(defun list args args)

(defun identity (x) x)

(defun acons ("atom" key datum "list" alist) (cons (cons key datum) alist))

(define doclist ())

(defun doc ("atom|string" key "string?" desc)
    (cond
	(desc
	    (progn
		(if (not (atom? key))
		    (err "can only add a docstring to an atom")
		)
		(if (not (bound? key))
		    (err "can only add a docstring to a bound atom - %s" (string key))
		)
		(setq! doclist (acons key desc doclist))
		t
	    )
	)
	((atom? key)
	    (progn
		(apropos key)
		(printf "%s\n\n" (assoc key doclist))
		t
	    )
	)
	((string? key)
	    (let*
		(e (env))
		(while e
		    (let*
			(a (car (car e)))
			(as (string a))
			(if (not (errex? (assoc a doclist)))
			    (let*
				(ds (assoc a doclist))
				(if (or
					(string-find as key)
					(string-find ds key)
				    )
				    (doc a)
				)
			    )
			)
		    )
		    (setq! e (cdr e))
		)
		t
	    )
	)
	(t (err "unknown key type"))
    )
)
(doc 'doc "Shows documentation of either the atom passed in, or all atoms matching the string passed in. With a second argument, adds that string as the documentation for the atom.")

(defun reverse ("list|string|vector" x)
    (cond
	((list? x)
	    (let*
		(r ())
		(while (cons? x)
		    (setq! r (cons (car x) r))
		    (setq! x (cdr x))
		)
		r
	    )
	)
	((string? x) (apply string-concat (reverse (string-split x))))
	((vector? x)
	    (let*
		(l (reverse (vector-split x)))
		(r (apply vector (cons (list-length l) l)))
		(vector-fill-set! r (vector-fill-get x))
		r
	    )
	)
	(t (err "invalid arg type"))
    )
)
(doc 'reverse "Reverses a list, string, or vector.")

(defun mapcar ("function" f "list" l)
    (if l
	(cons (f (car l)) (mapcar f (cdr l)))
	()
    )
)
(doc 'mapcar "Calls the function on each element of the list and returns a list of the results.") 

(defun map2car ("function" f "list" l1 "list" l2)
    (if (and l1 l2)
	(cons (f (car l1) (car l2)) (map2car f (cdr l1) (cdr l2)))
	()
    )
)
(doc 'map2car "Calls the two-argument function on corresponding elements of the two lists and returns a list of the results. If the lists are not the same lengths, it only proceeds until the shorter list runs out.") 

(defun list? (x)
    (if (cons? x)
	(list? (cdr x))
	(not x)
    )
)
(doc 'list? "Tests whether an object is a list or not.")

(define null? not)
(doc 'null? "An alias for (not).")

(defun first ("list" x)
    (car x)
)
(doc 'first "The first item in a list.")

(defun second ("list" x)
    (car (cdr x))
)
(doc 'second "The second item in a list.")

(defun third ("list" x)
    (car (cdr (cdr x)))
)
(doc 'third "The third item in a list.")

(defun fourth ("list" x)
    (car (cdr (cdr (cdr x))))
)
(doc 'fourth "The fourth item in a list.")

(defun fifth ("list" x)
    (car (cdr (cdr (cdr (cdr x)))))
)
(doc 'fifth "The fifth item in a list.")

(defun sixth ("list" x)
    (car (cdr (cdr (cdr (cdr (cdr x))))))
)
(doc 'sixth "The sixth item in a list.")

(defun seventh ("list" x)
    (car (cdr (cdr (cdr (cdr (cdr (cdr x)))))))
)
(doc 'seventh "The seventh item in a list.")

(defun eighth ("list" x)
    (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr x))))))))
)
(doc 'eighth "The eighth item in a list.")

(defun ninth ("list" x)
    (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr x)))))))))
)
(doc 'ninth "The ninth item in a list.")

(defun tenth ("list" x)
    (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr x))))))))))
)
(doc 'tenth "The tenth item in a list.")

(defun rest ("list" x)
    (cdr x)
)
(doc 'rest "Everything but the first item in a list.")

(defun > (a b) (< b a))
(doc '> "Tests whether the first argument is greater than the second. Args may be atoms, numbers, characters, or strings, but both must be the same type.")

(defun <= (a b) (not (> a b)))
(doc '<= "Tests whether the first argument is less than or equal to the second. Args may be atoms, numbers, characters, or strings, but both must be the same type.")

(defun >= (a b) (not (< a b)))
(doc '>= "Tests whether the first argument is greater than or equal to the second. Args may be atoms, numbers, characters, or strings, but both must be the same type.")

(defun = (a b) (and (<= a b) (>= a b)))
(doc '= "Tests whether the first argument is equal to the second. Args may be atoms, numbers, characters, or strings, but both must be the same type.")

(defun != (a b) (not (= a b)))
(doc '!= "Tests whether the first argument is not equal to the second. Args may be atoms, numbers, characters, or strings, but both must be the same type.")

(defun compare ("atom|number|character|string" a "atom|number|character|string" b)
    (cond
	((< a b) -1)
	((> a b) 1)
	(t 0)
    )
)
(doc 'compare "Compares the two arguments, returning -1, 0, or 1. Args may be atoms, numbers, characters, or strings, but both must be the same type.")

(defun seq ("integer" start "integer" limit)
    (letrec
	(seq-prepend
	    (lambda ("integer" l "list" x)
		(if (< start l)
		    (seq-prepend (- l 1) (cons (- l 1) x))
		    x
		)
	    )
	)
	(seq-prepend limit ())
    )
)
(doc 'seq "Returns a list of numbers from start to limit-1.")

(defun seqby ("integer" start "integer" limit "integer" step)
    (letrec
	(seqby-prepend
	    (lambda ("integer" l "list" x)
		(if (> (* step (- l start)) 0)
		    (seqby-prepend (- l step) (cons (- l step) x))
		    x
		)
	    )
	)
	(seqby-prepend (+ start step (* step (truncate (/ (- limit start (if (> step 0) 1 -1)) step)))) ())
    )
)
(doc 'seqby "Returns a list of numbers from start to limit-1 counting by step.")

(defun for-seq ("integer" start "integer" limit "function" f)
    (mapcar f (seq start limit))
)
(doc 'for-seq "Calls the function with arg from start to limit-1, and returns a list of the results.")

(defun for-seqby ("integer" start "integer" limit "integer" step "function" f)
    (mapcar f (seqby start limit step))
)
(doc 'for-seqby "Calls the function with arg from start to limit-1 counting by step, and returns a list of the results.")

(defun range ("integer" start "integer" limit "integer?" step)
    (if step
	(seqby start limit step)
	(seq start limit)
    )
)
(doc 'range "With two args, does seq; with three args, does seqby.")

(defun max args
    (let*
	(r (car args))
	(progn
	    (mapcar (lambda (x) (if (> x r) (setq! r x))) (cdr args))
	    r
	)
    )
)
(doc 'max "The largest number in the arguments.")

(defun min args
    (let*
	(r (car args))
	(progn
	    (mapcar (lambda (x) (if (< x r) (setq! r x))) (cdr args))
	    r
	)
    )
)
(doc 'min "The smallest number in the arguments.")

; sprintf and friends.
(define sprintf-defs ())
(doc 'sprintf-defs "A list of three-element lists representing formatters.")

(defun sprintf ("string" fmtstr . args)
    (letrec
	(lookup-def2
	    (lambda ("character" spec "list" defs)
		(if defs
		    (if (eql? spec (first (car defs)))
			(car defs)
			(lookup-def2 spec (cdr defs))
		    )
		    ()
		)
	    )
	)
	(lookup-def
	    (lambda ("character" spec)
		(lookup-def2 spec sprintf-defs)
	    )
	)
	; State machine! Start in state base.
	(state 'base)
	; Formatted fragments are collected in a list of strings and characters.
	(r ())
	(neg ())
	(wid 0)
	(spaces "                                                             ")
	(fmtone
	    (lambda ("string|character" x)
		(let*
		    (padding (string-substr spaces 0 (max (- wid (string-length x)) 0)))
		    (r ())
		    (if neg
			(setq! r (string-concat x padding))
			(setq! r (string-concat padding x))
		    )
		    (setq! neg ())
		    (setq! wid 0)
		    r
		)
	    )
	)
	(for-seq 0 (string-length fmtstr)
	    (lambda (i)
		(let*
		    (ch (string-chrat fmtstr i))
		    (cond
			((eql? state 'base)
			    (if (eql? ch '%')
				(setq! state 'spec)
				(setq! r (cons (fmtone ch) r))
			    )
			)
			((eql? state 'spec)
			    (cond
				((eql? ch '%')
				    (progn
					(setq! r (cons (fmtone "%") r))
					(setq! state 'base)
				    )
				)
				((eql? ch '-')
				    (setq! neg t)
				)
				((and (>= ch '0') (<= ch '9'))
				    (setq! wid (+ (* wid 10) (- (chrnum ch) (chrnum '0'))))
				)
				(t
				    (let*
					(def (lookup-def ch))
					(if (not def)
					    (err "unknown format spec '%%%c'" ch)
					    (let*
						(pred (second def))
						(tostr (third def))
						(if (not (cons? args))
						    (err "missing arg for format spec '%%%c'" ch)
						)
						(if (not (pred (car args)))
						    (err "arg type does not match format spec '%%%c'" ch)
						)
						(setq! r (cons (fmtone (tostr (car args))) r))
						(setq! args (cdr args))
						(setq! state 'base)
					    )
					)
				    )
				)
			    )
			)
		    )
		)
	    )
	)
	(if (not (eql? state 'base))
	    (err "format string has incomplete formatting spec")
	)
	; Turn the formatted fragments into a string, in the proper order.
	(apply string-concat (reverse r))
    )
)
(doc 'sprintf "Like C's sprintf(3). First argument is a format string, the rest are items to be formatted. Result is returned as a string. Formatting specs are a percent, an optional field width, and a letter. If the field width is negative, the padding is added on the right. New formatters can be added using the sprintf-add function. Default formatters:\n  %d integer\n  %g number\n  %c character\n  %s string\n  %v vector\n  %% a percent character")

(defun sprintf-add ("character" spec "function" pred "function" tostr)
    (setq! sprintf-defs (cons (list spec pred tostr) sprintf-defs))
)
(doc 'sprintf-add "Adds a new formatter. The args are the character to use after the '%', a single-arg predicate function that returns true if its arg's type matches the spec, and a single-arg function that converts its arg to a string. For many types the tostr function will just be: string, but some types will need other converters.")

(defun fprintf ("stream" s "string" fmtstr . args)
    (write-string (sprintf fmtstr . args) s)
)
(doc 'fprintf "Like C's fprintf(3). First argument is a stream, second is a format string, the rest are items to be formatted. Result is written to the stream. See the doc for sprintf for details on formatting.")

(defun printf ("string" fmtstr . args)
    (write-string (sprintf fmtstr . args))
)
(doc 'printf "Like C's printf(3). First argument is a format string, the rest are items to be formatted. Result is written to stdout. See the doc for sprintf for details on formatting.")

; Add default formatters.
(sprintf-add 'd' integer? string)
(sprintf-add 'g' number? string)
(sprintf-add 'c' character? identity)
(sprintf-add 's' string? identity)
(sprintf-add 'v' vector? string)


; Add doc strings for the stuff previously defined.
(doc 'defmacro "Defines a named macro. Like defun, a slightly less verbose way to add a new macro.")
(doc 'defun "Defines a named function. This is a macro that uses define and lambda to give a slightly less verbose way to add a new function.")
(doc 'err "Generate an error, with a message as payload. The message can use sprintf-style formatting specs.")
(doc 'list "Makes a list from the args.")
(doc 'identity "Returns its argument. Occasionally useful with functions that require a function as an argument.")
(doc 'acons "Adds a key/datum pair to an association list.")
(doc 'doclist "Association list of doc strings.")


; Doc strings for stuff initialized by liblmin.
(doc 't "Guaranteed-present atom used to indicate \"true\".")
(doc 'nan "Not a number.")
(doc 'inf "An infinite number.")
(doc 'stdin "A stream object corresponding to Unix stdin.")
(doc 'stdout "A stream object corresponding to Unix stdout.")
(doc 'stderr "A stream object corresponding to Unix stderr.")


; Doc strings for the primitives. First the special forms:
(doc 'quote "Returns its arg verbatim. No evaluation, error checking, or type checking. Can also be invoked by a prefixed apostrophe.")
(doc 'define "Adds a definition to the global environment.")
(doc 'lambda "Creates an executable closure with argument substitution. A closure is special kind of CONS cell representing an unnamed function and the symbol bindings it can see. If you use define to assign a name to it, you have a regular function.")
(doc 'macro "A simple macro facility. Macros are a special kind of CONS cell. They have a list of parameters, and a body expression. On invocation, the arguments get substituted into the body expression where the corresponding parameters appear. For example, here's a simple macro where the single parameter is a function to be called on a fixed list of arguments:\n  > (define m (macro (f) (f 1 2 3 4 5)))\n  m\n  > (m +)\n  15\n  > (m *)\n  120")
(doc 'or "Returns t if any of its args are true, otherwise nil. Does lazy evaluation - as soon as it finds a true arg, it returns.")
(doc 'and "Returns t if all of its args are true, otherwise nil. Does lazy evaluation - as soon as it finds a false arg, it returns.")
(doc 'cond "Evaluates a series of (test result) pairs. The result of the cond is the first result whose predicate is true.")
(doc 'if "Takes a test form and either one or two result forms. If the test form evaluates to true, the first result form is evaluated and returned; otherwise the second result form, or nil if there isn't one.")
(doc 'let* "Makes a series of local variable bindings and evaluates a series of forms in that environment. The bindings are evaluated in sequence and may refer to earlier ones.")
(doc 'let "Makes a series of local variable bindings and evaluates a series of forms in that environment. The bindings may not refer to earlier ones.")
(doc 'letrec "Makes a series of local variable bindings and evaluates a series of forms in that environment. The bindings may refer to either earlier or later ones, allowing recursion and even mutual recursion.")
(doc 'progn "Evaluates a series of forms. The result of the last one is returned.")
(doc 'while "Takes a test form and a series of other forms. Repeatedly checks the test form and evaluates the others if the test is true.")
(doc 'until "Takes a series of forms. Repeatedly evaluates them. The loop stops when the last form evaluates to false.")
(doc 'catch "The first arg is an optional atom that tags this catch. The rest of the args are evaluated like a progn, with the result of the last one returned. If a throw with a matching tag happens, that value is returned instead. If no tag was specified, any throw matches.")
(doc 'setq! "Sets an atom's value. The atom can be either pre-existing or new. The q means the atom name is not evaluated so you don't have to quote it. The ! indicates that it modifies an existing object, an unusual operation worth paying extra attention to.")
(doc 'permq "Marks an atom as permanent, which means it is immune to garbage collection whether it is referenced or not. The q means the atom name is not evaluated so you don't have to quote it.")
(doc 'errex? "Tests whether an object is an error/exception or not.")
(doc 'time "Evaluates its argument, then reports the real/user/system time it used.")
; And the regular form primitives:
(doc 'cons "Creates a CONS pair out of \"ar\" and \"dr\" objects.")
(doc 'car "Returns the \"ar\" part of a CONS pair.")
(doc 'cdr "Returns the \"dr\" part of a CONS pair.")
(doc 'eval "Evaluates its argument and returns the result.")
(doc '+ "Adds up its numeric arguments.")
(doc '- "Subtracts the 2nd through last numeric arguments from the first arg.")
(doc '* "Multiplies its numeric arguments.")
(doc '/ "Divides the first argument by the 2nd through last args.")
(doc 'truncate "Coerces a possibly floating-point numeric argument to be an integer.")
(doc 'floor "The closest integer less than or equal to a number.")
(doc '< "Tests whether the first argument is less than the second. Args may be atoms, numbers, characters, or strings, but both must be the same type.")
(doc 'ash "Does a bit-shift on the first arg by the second arg number of bits. Left if shift count is positive, right if negative.")
(doc 'sqrt "Square root.")
(doc 'expt "Exponentiation - a ^ b. Has a special case for integer args.")
(doc 'sin "Sine.")
(doc 'cos "Cosine.")
(doc 'tan "Tangent.")
(doc 'exp "e to the x.")
(doc 'log "Natural logarithm.")
(doc 'asin "Arc-sine.")
(doc 'acos "Arc-cosine.")
(doc 'atan "Arc-tangent. Takes either one or two arguments.")
(doc 'eq? "Tests if the two arguments are exactly the same object.")
(doc 'eql? "Tests if the two arguments have the same value.")
(doc 'atom? "Tests whether an object is an ATOM or not.")
(doc 'cons? "Tests whether an object is a CONS or not.")
(doc 'closure? "Tests whether an object is a closure or not.")
(doc 'macro? "Tests whether an object is a macro or not.")
(doc 'prim? "Tests whether an object is a PRIM or not.")
(doc 'number? "Tests whether an object is a number or not.")
(doc 'integer? "Tests whether an object is an integer number or not.")
(doc 'character? "Tests whether an object is a character or not.")
(doc 'string? "Tests whether an object is a string or not.")
(doc 'stream? "Tests whether an object is a stream or not.")
(doc 'vector? "Tests whether an object is a VECTOR or not.")
(doc 'data? "Tests whether an object is a DATA or not.")
(doc 'not "Reverses the truth sense of its argument - nil returns t, anything non-nil returns nil.")
(doc 'assoc "Looks up an atom in an association list. Returns an error if not found.")
(doc 'rplaca "Changes the \"ar\" part of an existing CONS cell.")
(doc 'rplacd "Changes the \"dr\" part of an existing CONS cell.")
(doc 'write "Writes an object to a stream, default stdout.")
(doc 'write-string "Writes a string to a stream, default stdout.")
(doc 'read "Reads an object from a stream, default stdin. The object may span multiple lines, but multiple objects on one line is not supported.")
(doc 'read-char "Reads one character from a stream, default stdin.")
(doc 'read-line "Reads one line from a stream, default stdin.")
(doc 'env "Returns the current global environment. Note that this is not an atom, it's a function. This doesn't work: \"(write-line env)\". Do this instead: \"(write-line (env))\".")
(doc 'callstack "Returns the current call stack, which can be useful for debugging.")
(doc 'usleep "Sleeps for n microseconds.")
(doc 'random "With an integer arg, returns a random integer in [0..arg); with no arg, returns a random integer.")
(doc 'parse-integer "Parses a string into an integer; generates an error on malformed ints.")
(doc 'chr "Makes a character with the ASCII value of the argument.")
(doc 'chrnum "Returns the ASCII value of the character argument.")
(doc 'chr-tolower "Converts a character to lower case.")
(doc 'chr-toupper "Converts a character to upper case.")
(doc 'chr-isspace "Tests if a character is whitespace.")
(doc 'string "Converts any object into a string representation.")
(doc 'string-length "Returns the length of a string.")
(doc 'string-chrat "Returns the character at the specified position in the string. Uses zero-based indexing. Out of bounds positions generate an error.")
(doc 'string-substr "Returns a new string with the specified substring of the argument. Arguments are string, position, and length. If the length is not specified, it defaults to the rest of the string. Out of bounds positions / lengths generate an error.")
(doc 'string-concat "Concatenate multiple strings or characters, returning a new string.")
(doc 'string-find "Search a string. Arguments are string and either a character or another string. Returns the position, or nil if not found.")
(doc 'vector "Creates a vector of the specified initial length. Any args after the length are used to fill in the initial values; if there aren't enough args, the last arg is repeated. The last arg is also used for the vector's 'fill' value, to fill in new values when the vector gets lengthened.")
(doc 'vector-length "Returns the length of a vector.")
(doc 'vector-length-set! "Sets the length of a vector.")
(doc 'vector-get "Gets an element of a vector.")
(doc 'vector-set! "Sets an element of a vector to a new value. If the vector isn't long enough, it gets lengthened.")
(doc 'vector-fill-get "Gets the fill value of a vector. This is used to fill in new elements when the vector gets lengthened.")
(doc 'vector-fill-set! "Sets the fill value of a vector to a new value. This is used to fill in new elements when the vector gets lengthened.")
(doc 'err-make "Generate an error, with a string message as payload.")
(doc 'open "Open a file, returning a stream. The mode is the usual Unix fopen(3) values: \"r\" for read, \"w\" for write, \"a\" for append, and \"r+\" for read/write.")
(doc 'close "Close a stream.")
(doc 'flush "Flush any buffered but not yet written data on a stream.")
(doc 'apply "Apply takes two args: a function to call, and a list of arguments to call it with:\n  (apply fun (arg1 arg2 arg3 ...))\nIt rearranges things so the function and args are in the same list:\n  (fun arg1 arg2 arg3 ...)\nThen it evaluates that. So for example:\n  (apply + '(1 2 3))\nwould return 6.")
(doc 'funcall "Funcall evaluates its argument list as if it was a function call. For example:\n  (funcall + 1 2 3)\nreturns 6.")
(doc 'bound? "Tests if an atom is bound to a value in the global environment. Lexical bindings are ignored.")
(doc 'throw "Takes an optional atom tag, and a value. Does a non-local return of the value to the nearest catch form with a matching tag. If no tag is specified, any catch matches.")
(doc 'apropos "Shows a basic description of either the atom passed in, or all atoms matching the string passed in.")
(doc 'apropos-list "Returns a list of all atoms matching a search string.")
(doc 'room "Reports on memory usage.")
(doc 'census "Reports on cell counts.")
(doc 'celldump "Shows a complete dump of one cell.")


(defun equal? (x y)
    (or
	(eql? x y)
	(and
	    (cons? x)
	    (cons? y)
	    (equal? (car x) (car y))
	    (equal? (cdr x) (cdr y))
	)
    )
)
(doc 'equal? "Tests the entire tree structure of the arguments for equality.")

(defun negate ("number" n) (- 0 n))
(doc 'negate "Negates a number.")

(defun cadr ("cons" x) (car (cdr x)))
(doc 'cadr "Shortcut for (car (cdr x)).")

(defun caddr ("cons" x) (car (cdr (cdr x))))
(doc 'caddr "Shortcut for (car (cdr (cdr x))).")

(define begin progn)
(doc 'begin "An alias for (progn).")

(define set-car! rplaca)
(doc 'set-car! "An alias for (rplaca).")

(define set-cdr! rplacd)
(doc 'set-cdr! "An alias for (rplacd).")

(defun list-tail ("list" x "number" n) (nthcdr n x))
(doc 'list-tail "Returns the list with the first n items skipped. Like nthcdr with the argument order switched.")

(defun list-ref ("list" x "number" n) (nth n x))
(doc 'list-ref "Returns the nth list member counting from zero. Like nth with the argument order switched.")

(define pi 3.1415926535897932384626433)
(doc 'pi "The famous mathematical constant.")

(defun abs ("number" n)
    (if (< n 0)
	(- 0 n)
	n
    )
)
(doc 'abs "Returns the absolute value of a number.")

(defun frac ("number" n) (- n (truncate n)))
(doc 'frac "Returns the fractional part of a number.")

(define int truncate)
(doc 'int "An alias for (truncate).")

(defun ceiling ("number" n) (negate (floor (negate n))))
(doc 'ceiling "The closest integer greater than or equal to a number.")

(defun signum ("number" n) (cond ((> n 0) 1) ((< n 0) -1) (t 0)))
(doc 'signum "The sign of a number - either 1, 0, or -1.")

(defun round ("number" n)
    (truncate (+ n (* (signum n) 0.5)))
)
(doc 'round "The closest integer to a number.")

(defun negative? ("number" n) (< n 0))
(doc 'negative? "Whether a number is negative or not.")

(defun zero? ("number" n) (= n 0))
(doc 'zero? "Whether a number is zero or not.")

(defun positive? ("number" n) (> n 0))
(doc 'positive? "Whether a number is positive or not.")

(defun rem ("integer" n "integer" m)
    (- n (* m (truncate (/ n m))))
)
(doc 'rem "Returns the remainder of dividing n by m. See also mod.")

(defun mod ("integer" n "integer" m)
    (let*
	(r (rem n m))
	(if (negative? r)
	    (+ r m)
	    r
	)
    )
)
(doc 'mod "Returns n modulo m. See also rem.")

(defun gcd ("integer" n "integer" m)
    (if (eql? m 0)
	n
	(gcd m (mod n m))
    )
)
(doc 'gcd "Greatest common divisor of two numbers. If you want the gcd of more than two numbers, you could use reduce: (reduce gcd '(36394865 13592801 13345345))")

(defun lcm ("integer" n "integer" m) (/ (* n m) (gcd n m)))
(doc 'lcm "Lowest common multiple of two numbers.")

(defun even? ("number" n) (eql? (mod n 2) 0))
(doc 'even? "Whether a number is even.")

(defun odd? ("number" n) (eql? (mod n 2) 1))
(doc 'odd? "Whether a number is odd.")

(defun bit ("number" n "number" i)
    (if (odd? (ash n (negate i)))
	1
	0
    )
)
(doc 'bit "The ith bit in a number. The least-significant bit is index 0.")

(defun bits ("number" n)
    (cond
	((negative? n) (bits (abs n)))
	((<= n 1) 1)
	(t (+ (bits (ash n -1)) 1))
    )
)
(doc 'bits "How many bits are in a number.")

(defun square ("number" x) (* x x))
(doc 'square "Returns the square of a number.")

(defun isqrt ("integer" n)
    (cond
	((< n 0) nan)
	((= n 0) 0)
	((= n 1) 1)
	(t
	    (let*
		(est1 (truncate (/ n 2)))
		(est2 (truncate (/ n est1)))
		(diff (- est1 est2))
		(progn
		    (while (> (abs diff) 1)
			(setq! est1 (truncate (/ (+ est1 est2) 2)))
			(setq! est2 (truncate (/ n est1)))
			(setq! diff (- est1 est2))
		    )
		    (if (= diff 1)
			est2
			est1
		    )
		)
	    )
	)
    )
)
(doc 'isqrt "Returns the integer square root of a number - the largest int smaller than the square root.")

(defun list-length ("list" l)
    (let*
	(n 0)
	(while (cons? l)
	    (setq! n (+ n 1))
	    (setq! l (cdr l))
	)
	n
    )
)
(doc 'list-length "The length of a list.")

(defun append (x . args)
    (letrec
	(append-helper
	    (lambda (s y)
		(if s
		    (cons (car s) (append-helper (cdr s) y))
		    y
		)
	    )
	)
	(if args
	    (append-helper x (append . args))
	    x
	)
    )
)
(doc 'append "Concatenates the args. They must all be lists except for the last one which may be any object.")

(defun nthcdr ("number" n "list" x)
    (if (eql? n 0)
	x
	(nthcdr (- n 1) (cdr x))
    )
)
(doc 'nthcdr "Returns the list with the first n items skipped. Like list-tail with the argument order switched.")

(defun nth ("number" n "list" x) (car (nthcdr n x)))
(doc 'nth "Returns the nth list member counting from zero. Like list-ref with the argument order switched.")

(defun member (x "list" l)
    (if l
	(if (equal? x (car l))
	    l
	    (member x (cdr l))
	)
	l
    )
)
(doc 'member "Searches a list for an object; if it's found, returns the list starting at that object, otherwise nil. Member equality is checked with (equal?).")

(defun foldr ("function" f "list" l x)
    (if l
	(f (car l) (foldr f (cdr l) x))
	x
    )
)
(doc 'foldr "Use the function to combine the first element of the list with the result of recursively combining the rest. This is like a binary operator being right-associative. The third parameter, x, is used when the list ends; if you don't want to use it, pass in the identity element of the function.")

(defun foldl ("function" f "list" l x)
    (if l
	(foldl f (cdr l) (f (car l) x))
	x
    )
)
(doc 'foldl "Use the function to combine the result of recursively combining all list elements but the last one, with the last element. This is like a binary operator being left-associative. The third parameter, x, is used when the list ends; if you don't want to use it, pass in the identity element of the function.")

(defun filter ("function" f "list" x)
    (if x
	(if (f (car x))
	    (cons (car x) (filter f (cdr x)))
	    (filter f (cdr x))
	)
	()
    )
)
(doc 'filter "Calls the function with each element of the list and returns a new list with only the ones that gave non-nil results.")

(defun all? ("function" f "list" x)
    (if x
	(if (f (car x))
	    (all? f (cdr x))
	    ()
	)
	t
    )
)
(doc 'all? "Calls the function with each element of the list and returns t if they all gave non-nil results.")

(defun any? ("function" f "list" x)
    (if x
	(if (f (car x))
	    t
	    (any? f (cdr x))
	)
	()
    )
)
(doc 'any? "Calls the function with each element of the list and returns t if any of them gave non-nil results.")

(defun reduce ("function" f "list" l)
    (cond
	((not l) ())
	((not (cons? l)) l)
	((not (cdr l)) (car l))
	(t (f (car l) (reduce f (cdr l))))
    )
)
(doc 'reduce "Reduces a list of values down to one by calling the function with two values at a time. For example, finding the gcd of more than two numbers:\n  (reduce gcd '(36394865 13592801 13345345))")

(defun vector-split ("vector" v)
    (let*
	(l ())
	(mapcar (lambda (i) (setq! l (cons (vector-get v i) l))) (seqby (- (vector-length v) 1) -1 -1))
	l
    )
)
(doc 'vector-split "Split a vector into a list.")

(defun vector-map ("function" f "vector" v)
    (let*
	(r (vector (vector-length v)))
	(for-seq
	    0 (vector-length v)
	    (lambda (i)
		(vector-set! r i (f (vector-get v i)))
	    )
	)
	r
    )
)
(doc 'vector-map "Calls the function on each element of the vector and returns a vector of the results.") 

(defun vector-map2 ("function" f "vector" v1 "vector" v2)
    (let*
	(l1 (vector-length v1))
	(l2 (vector-length v2))
	(l (max l1 l2))
	(r (vector l))
	(for-seq
	    0 l
	    (lambda (i)
		(vector-set! r i (f (vector-get v1 i) (vector-get v2 i)))
	    )
	)
	r
    )
)
(doc 'vector-map2 "Calls the two-argument function on corresponding elements of the two vectors and returns a vector of the results. If the vectors are not the same length, the shorter vector's fill setting is used.") 

(defun vector-find ("vector" v x)
    (letrec
	(l (vector-length v))
	(vector-find-recur
	    (lambda (i)
		(cond
		    ((>= i l) ())
		    ((equal? x (vector-get v i)) i)
		    (t (vector-find-recur (+ i 1)))
		)
	    )
	)
	(vector-find-recur 0)
    )
)
(doc 'vector-find "Search for an object in a vector. Returns the index if found, otherwise nil.")

(defun vector-filter ("function" f "vector" v)
    (letrec
	(r (vector 0))
	(vector-filter-recur
	    (lambda (i)
		(if (f (vector-get v i))
		    (vector-set! r (vector-length r) (vector-get v i))
		)
	    )
	)
	(for-seq 0 (vector-length v) vector-filter-recur)
	r
    )
)
(doc 'vector-filter "Calls the function with each element of the vector and returns a new vector with only the ones that gave non-nil results.")

(defun vector-all? ("function" f "vector" v)
    (letrec
	(l (vector-length v))
	(vector-all?-recur
	    (lambda (i)
		(cond
		    ((>= i l) t)
		    ((not (f (vector-get v i))) ())
		    (t (vector-all?-recur (+ i 1)))
		)
	    )
	)
	(vector-all?-recur 0)
    )
)
(doc 'vector-all? "Calls the function with each element of the vector and returns t if they all give non-nil results.")

(defun vector-any? ("function" f "vector" v)
    (letrec
	(l (vector-length v))
	(vector-any?-recur
	    (lambda (i)
		(cond
		    ((>= i l) ())
		    ((f (vector-get v i)) t)
		    (t (vector-any?-recur (+ i 1)))
		)
	    )
	)
	(vector-any?-recur 0)
    )
)
(doc 'vector-any? "Calls the function with each element of the vector and returns t if any of them gave non-nil results.")

(defun vector-sum ("vector" v)
    (let*
      (sum 0)
      (for-seq
	  0 (vector-length v)
	  (lambda (i)
	      (setq! sum (+ sum (vector-get v i)))
	  )
      )
      sum
    )
)
(doc 'vector-sum "Adds up the components of a vector.")

(defun vector-magnitude ("vector" v)
    (sqrt (vector-sum (vector-map square v)))
)
(doc 'vector-magnitude "The magnitude of a vector is its Pythagorean length if the components are interpreted as coordinates in N-dimensional space.")

(defun vector-normalize ("vector" v)
    (let*
	(mag (vector-magnitude v))
	(vector-map (lambda (x) (/ x mag)) v)
    )
)
(doc 'vector-normalize "A normalized vector points in the same direction as the original but has a magnitude of exactly 1.")

(defun vector-dotproduct ("vector" v1 "vector" v2)
    (vector-sum (vector-map2 (lambda (x y) (* x y)) v1 v2))
)
(doc 'vector-dotproduct "Returns the dot product of the two vectors.")

(defun string-split ("string" s)
    (let*
	(p (- (string-length s) 1))
	(l ())
	(while (>= p 0)
	    (setq! l (cons (string-chrat s p) l))
	    (setq! p (- p 1))
	)
	l
    )
)
(doc 'string-split "Returns a list of the characters in a string.")

(define nil? null?)
(doc 'nil? "An alias for (null?).")

(defun write-line (c "stream?" s)
    (progn
	(if (not s) (setq! s stdout))
	(write c s)
	(fprintf s "\n")
    )
)
(doc 'write-line "Writes an object to a stream, default stdout, followed by a newline.")

(defun write-char ("character" c "stream?" s)
    (progn
	(if (not s) (setq! s stdout))
	(fprintf s "%c" c)
    )
)
(doc 'write-char "Writes one character to a stream, default stdout.")

(defun sleep ("number" n) (usleep (truncate (* secs 1000000))))
(doc 'sleep "Sleeps for n seconds.")

(defun copy-tree (x)
    (cond
	((cons? x) (cons (copy-tree (car x)) (copy-tree (cdr x))))
	(t x)
    )
)
(doc 'copy-tree "Copies an entire CONS tree. The leaf nodes are shared with the original.")

(defun union ("list" l1 "list" l2)
    (if l2
	(if (member (car l2) l1)
	    (union l1 (cdr l2))
	    (union (cons (car l2) l1) (cdr l2))
	)
	l1
    )
)
(doc 'union "Returns a list of the items that are in either l1 or l2.")

(defun intersection ("list" l1 "list" l2)
    (if l1
	(if (member (car l1) l2)
	    (cons (car l1) (intersection (cdr l1) l2))
	    (intersection (cdr l1) l2)
	)
	l1
    )
)
(doc 'intersection "Returns a list of the items that are in both l1 and l2.")

(defun difference ("list" l1 "list" l2)
    (if l1
	(if (member (car l1) l2)
	    (difference (cdr l1) l2)
	    (cons (car l1) (difference (cdr l1) l2))
	)
	l1
    )
)
(doc 'difference "Returns a list of the items that are in l1 but not in l2.")

(defun subset? ("list" l1 "list" l2)
    (not (difference l1 l2))
)
(doc 'subset? "Whether l1 is a subset of l2.")

(defun constantly (x) (lambda () x))
(doc 'constantly "Returns a function that always returns x.")

(defun alist-keys ("list" alist)
    (let*
	(r ())
	(while (cons? alist)
	    (setq! r (cons (car (car alist)) r))
	    (setq! alist (cdr alist))
	)
	r
    )
)
(doc 'alist-keys "Returns a list of the keys in an alist.")

(defun float? ("number" x) (not (integer? x)))
(doc 'float? "Tests whether an object is a float number or not.")

(defun traverse ("function" f o)
    (cond
	((cons? o) (append (traverse f (car o)) (traverse f (cdr o))))
	((vector? o)
	    (let*
		(l ())
		(mapcar (lambda (i) (setq! l (append (traverse f (vector-get o i)) l))) (reverse (seq 0 (vector-length o))))
		l
	    )
	)
	((nil? o) o)
	(t (list (f o)))
    )
)
(doc 'traverse "Calls the function on each leaf element of the object and returns a list of the results. Like mapcar but for generalized tree structures, including vectors, not just proper lists.")

(defmacro swap (a b)
    (let*
	(swap-tmp a)
	(setq! a b)
	(setq! b swap-tmp)
	t
    )
)
(doc 'swap "Swap the values of two atoms.")

(defmacro repeat (body)
    (while t
	body
    )
)
(doc 'repeat "Evaluates the body repeatedly.")

(defun uniq ("list" l)
    (let*
	(r ())
	(while (cons? l)
	    (if (not (member (car l) r))
		(setq! r (cons (car l) r))
	    )
	    (setq! l (cdr l))
	)
	(reverse r)
    )
)
(doc 'uniq "Returns a new list with any duplicate elements removed. Member equality is checked with (equal?).")

(defun vector-copy ("vector" v)
    (apply vector (cons (vector-length v) (vector-split v)))
)
(doc 'vector-copy "Copies a vector.")

(defun sort ("list" l "function?" cmp)
    (cond
	((not cmp) (sort l compare))	; use default comparator
	((<= (list-length l) 1) l)	; already sorted
	(t
	    (letrec
		(merge
		    (lambda (l1 l2)
			(let*
			    (r ())
			    ; Merge until a list runs out. We prepend to
			    ; the list and then reverse it at the end,
			    ; which is much faster than appending.
			    (while (and (cons? l1) (cons? l2))
				(if (<= (cmp (car l1) (car l2)) 0)
				    (progn
					(setq! r (cons (car l1) r))
					(setq! l1 (cdr l1))
				    )
				    (progn
					(setq! r (cons (car l2) r))
					(setq! l2 (cdr l2))
				    )
				)
			    )
			    ; Add the remaining items.
			    (while (cons? l1)
				(setq! r (cons (car l1) r))
				(setq! l1 (cdr l1))
			    )
			    (while (cons? l2)
				(setq! r (cons (car l2) r))
				(setq! l2 (cdr l2))
			    )
			    ; Return merged result.
			    (reverse r)
			)
		    )
		)
		(left ())
		(right ())
		(len (list-length l))
		(leno2 (truncate (/ len 2)))
		(i 0)
		; Split the list into approximate halves. Again, prepend
		; and reverse instead of appending.
		(while (cons? l)
		    (if (< i leno2)
			(setq! left (cons (car l) left))
			(setq! right (cons (car l) right))
		    )
		    (setq! i (+ i 1))
		    (setq! l (cdr l))
		)
		; Recursively sort the two parts, and merge the results.
		(merge (sort (reverse left) cmp) (sort (reverse right) cmp))
	    )
	)
    )
)
(doc 'sort "Sorts a list from lowest to highest. Member types must be comparable using (compare): numbers, atoms, characters, or strings. Or, you can pass in your own 1/0/-1 comparator function.")

(defun doc-check ()
    (progn
	(printf "atoms in env but not in doclist:\n")
	(write-line (difference (alist-keys (env)) (alist-keys doclist)))
	(printf "atoms in doclist but not in env:\n")
	(write-line (difference (alist-keys doclist) (alist-keys (env))))
    )
)
(doc 'doc-check "Shows things that are globally bound but not documented, or the reverse. If you write your own add-ons, use this to make sure they are all documented.")
