;; -*- lisp -*-
;; SPDX-License-Identifier: BSD-2-Clause
(setq quote (lambda (a) (quote a)))
(setq atom (lambda (a) (atom a)))
(setq eq (lambda (a b) (eq a b)))
(setq car (lambda (a) (car a)))
(setq cdr (lambda (a) (cdr a)))
(setq cons (lambda (a b) (cons a b)))
(setq list (lambda a a))
(setq not (lambda (a) (not a)))
(setq null (lambda (a) (null a)))
(setq equal (lambda (a b) (equal a b)))
(setq caar (lambda (a) (caar a)))
(setq cadr (lambda (a) (cadr a)))
(setq cdar (lambda (a) (cdar a)))
(setq cddr (lambda (a) (cddr a)))
(setq memq (lambda (a b) (memq a b)))
(setq member (lambda (a b) (member a b)))
(setq assoc (lambda (a b) (assoc a b)))
(setq setq nil)
(setq caaar (lambda (a) (caaar a)))
(setq caadr (lambda (a) (caadr a)))
(setq cadar (lambda (a) (cadar a)))
(setq caddr (lambda (a) (caddr a)))
(setq cdaar (lambda (a) (cdaar a)))
(setq cdadr (lambda (a) (cdadr a)))
(setq cddar (lambda (a) (cddar a)))
(setq cdddr (lambda (a) (cdddr a)))
(setq rplaca (lambda (a b) (rplaca a b)))
(setq rplacd (lambda (a b) (rplacd a b)))
(setq nreverse (lambda (a) (nreverse a)))
(setq nconc (lambda (a b) (nconc a b)))
(setq append (lambda (a b) (append a b)))
(setq apply (lambda xs (apply xs)))
(setq string-length (lambda (s) (string-length s)))
(setq print (lambda (a) (print a)))
(setq progn nil)
(setq macro nil)
(setq expand1 (lambda (a) (expand1 a)))
(setq eval (lambda (a) (eval a)))
(setq mapcar (lambda (f a)
(label ((map
(lambda (a r)
(cond ((eq a nil) (nreverse r))
(true (map (cdr a)
(cons (f (car a)) r)))))))
(map a nil))))
(macro let (lambda (body)
(label ((names (mapcar car (car body)))
(values (mapcar cadr (car body))))
(list 'progn
(append
(list (append
(list (quote lambda) names)
(cdr body)))
values)))))
(macro q (lambda (x) (list (quote quote) (car x))))
(setq foldl (lambda (f z xs)
(cond ((atom xs) (f z xs))
((null xs) z)
((null (cdr xs)) (f z (car xs)))
(true (foldl f (f z (car xs))
(cdr xs))))))
(setq reduce (lambda (f xs)
(cond ((null xs) nil)
((atom xs) xs)
((null (cdr xs)) (car xs))
(true (foldl f (car xs) (cdr xs))))))
(setq mappend (lambda (f xs)
(reduce append (mapcar f xs))))
(macro quasiquote (lambda (lis)
(label ((qq1
(lambda (an)
(cond ((atom an)
(list 'list (list 'quote an)))
((eq (car an) 'unquote)
(list 'list (cadr an)))
((eq (car an) 'unquote-splicing)
(cadr an))
(true (list 'list
(list 'reduce 'append
(cons 'list (mapcar qq1 an)))))
))))
(cond ((atom (car lis)) (list 'quote (car lis)))
(true (list 'reduce 'append
(cons 'list
(mapcar qq1 (car lis)))))))))
(macro let* (lambda (a)
(cond ((null (car a)) `(progn ,@(cdr a)))
(true `(let (,(caar a))
(let* ,(cdar a)
,@(cdr a)))))))
(macro defun (lambda (args)
`(setq ,(car args)
(lambda ,(cadr args) ,@(cddr args)))))
(macro defintrinsic (lambda (args)
`(setq ,(car args)
(lambda ,(cadr args)
(,(car args) ,@(cadr args))))))
(defintrinsic only2+ (a b))
(defun + xs (foldl only2+ 0 xs))
(defintrinsic only2* (a b))
(defun * xs (foldl only2* 1 xs))
(defintrinsic only2- (a b))
(defun - xs (reduce only2- xs))
(defintrinsic only2/ (a b))
(defun / xs (reduce only2/ xs))
(defintrinsic only2// (a b))
(defun // xs (reduce only2// xs))
(defintrinsic only2% (a b))
(defun % xs (reduce only2% xs))
(defintrinsic only2** (a b))
(defun ** xs (reduce only2** xs))
(defintrinsic atan2 (a b))
(defintrinsic cos (a))
(defintrinsic sin (a))
(defintrinsic exp (a))
(defintrinsic log (a))
(defintrinsic sqrt (a))
(defun rand () (rand))
(defintrinsic srand (a))
(defintrinsic int (a))
(defintrinsic unsafe-system (a))
(defintrinsic shellquote (a))
(defun intercalate (it them)
(cond ((null them))
((null (cdr them)) them)
(true (cons (car them)
(cons it
(intercalate it (cdr them)))))))
(defun string-join args
(apply strcat (intercalate (car args) (cdr args))))
(defun system argv
;; if you pass symbols in, they will be appended to the command line
;; un-shellquoted. for example: (system "false" '2> "/dev/null")
(label ((shellquote-string
(lambda (x) (cond ((stringp x) (shellquote x))
((symbolp x) (sprintf "%s" x))))))
(let* ((words (mapcar shellquote-string argv))
(command (apply string-join " " words)))
(cond (*show-system-command*
(*show-system-command* command)))
(unsafe-system command))))
(defintrinsic tolower (s))
(defintrinsic toupper (s))
(defun substr xs
(cond ((eq (list-length xs 2))
(substr (car xs) (cadr xs)))
(true (substr (car xs) (cadr xs) (caddr xs)))))
(defintrinsic index (s t))
(defintrinsic match (s r))
(defintrinsic split (s fs))
(defintrinsic sub (r t s))
(defintrinsic gsub (r t s))
(setq sprintf nil)
(setq printf nil)
(defintrinsic strcat (xs))
(defintrinsic getline ())
(setq with-ors nil)
(setq with-output-to nil)
(setq with-input-from nil)
(defintrinsic fflush ())
(defintrinsic close (fn))
(defintrinsic as-number (s))
(defintrinsic gc-dot (marks-dot-fn sweeps-dot-fn))
(defintrinsic gc ())
(defintrinsic dump-dot (heap-dot-fn))
(defintrinsic dump ())
(defintrinsic dump-append ())
(defintrinsic load (fn))
(macro or (lambda (args)
(label ((clause (lambda (form) `(,form))))
`(cond ,@(mapcar clause args)
(true false)))))
(macro and (lambda (args)
(label ((clause (lambda (form) `((not ,form) false))))
`(cond ,@(mapcar clause args)
(true)))))
(defun save-lisp-and-die (me-file new-file main-symbol)
(let* ((image-begin "# IMAGE BEGINS QMGFAMRISGQJ48IWDOWPHOOGW3MLKKGSPXD4DTFIG0")
(script (sprintf "/^%s/ { exit 0 } { print }" image-begin)))
;; iterating over this many lines in glotawk was suuuper slow,
;; let's use awk instead lol
(system "awk" script me-file '> new-file)
(dump-append-changing-main new-file main-symbol)
(system "chmod" "+x" new-file)))