;;;; utils.lisp -- some random utils I collect. might be useful, probably won't be.
( defpackage :flan-utils
( :use :cl )
( :nicknames :fu ) )
( in-package :flan-utils )
( defmacro export* ( &rest syms )
"Export all symbols"
( cons 'progn ( mapcan #' ( lambda ( x ) ` ( ( export ',x ) ) ) syms ) ) )
( defmacro eval-all ( syms )
"Eval all statements, return in list."
` ( mapcar #' eval ' ( ,@ syms ) ) )
( export 'eval-all )
( defmacro export*! ( &rest syms )
"Eval all statements export return values"
` ( mapc #' export ( eval-all , syms ) ) )
( export 'export* )
( export 'export*! )
( defmacro defexport ( &rest val )
"Same as export*! for some reason"
` ( export*! ,@ val ) )
( export 'defexport )
( defun file-get-contents ( filename )
"Read file into string"
( with-open-file ( stream filename )
( let ( ( contents ( make-string ( file-length stream ) ) ) )
( read-sequence contents stream )
contents ) ) )
( export 'file-get-contents )
( defparameter *old-readtables* nil )
( defexport
;;; --- actual (exported) code goes here --
( defun copy-stream ( from to &key ( buffer-size 4096 ) )
"Block copy byte streams"
( let ( ( buffer ( make-array buffer-size :element-type ' ( unsigned-byte 8 ) ) ) )
( loop for bytes-read = ( read-sequence buffer from )
while ( plusp bytes-read )
do ( write-sequence buffer to :end bytes-read ) ) ) )
( defun real-copy-file ( from to )
"Copy a file"
( with-open-file ( from from :direction :input :element-type ' ( unsigned-byte 8 ) )
( with-open-file ( to to :direction :output :if-exists :supersede :element-type ' ( unsigned-byte 8 ) )
( copy-stream from to ) ) ) )
( defun real-move-file ( from to )
"Actually move a file"
( real-copy-file from to )
( delete-file from ) )
( defmacro errors ( stmt )
` ( let ( ( ret ( handler-case ( cons , stmt nil )
( t ( c ) ( cons nil c ) ) ) ) )
( values ( car ret ) ( cdr ret ) ) ) )
( defmacro try-catch ( try &body catch )
( let ( ( errnm ( gensym ) ) )
` ( let ( ( , errnm ( handler-case ( cons , try nil )
( t ( e )
( let ( ( e e ) )
( cons ( progn ,@ catch ) e ) ) ) ) ) )
( if ( cdr , errnm )
( values ( car , errnm ) ( cdr , errnm ) )
( values ( car , errnm ) nil ) ) ) ) )
( defmacro try ( &body body )
` ( try-catch
( progn
,@ body )
nil ) )
( defmacro try-catch-finally ( try catch &body finally )
( let ( ( ret ( gensym ) )
( err ( gensym ) ) )
` ( multiple-value-bind ( , ret , err ) ( try-catch , try , catch )
( values ( progn ,@ finally ) , ret , err ) ) ) )
( defmacro try-finally ( try &body finally )
` ( try-catch-finally
, try
nil
,@ finally ) )
( defmacro val-if-or ( val test or )
"(if (test val) val or)"
` ( let ( ( vv , val ) )
( if ( funcall , test vv ) vv , or ) ) )
( defun where ( expr items )
( mapcan #' ( lambda ( x )
( when ( funcall expr x ) ( list x ) ) )
items ) )
( defun true ( f )
( not ( null f ) ) )
( defun nop ( )
"Do nothing"
nil )
( defun yep ( )
"Do nothing"
t )
( defun mapline ( input fi &key ( read-line #' read-line ) )
"Map lines from stream"
( loop for line = ( funcall read-line input nil )
while line do ( funcall fi line ) ) )
( defun strcat ( &rest str )
"Concat all strings, if item is not string it is written to one."
( apply #' concatenate ( cons 'string ( mapcar #' ( lambda ( x )
( typecase x
( string x )
( character ( string x ) )
( t ( write-to-string x ) ) ) )
str ) ) ) )
( defmacro strcat-fast ( &rest strings )
"Concat all strings, they need to be strings. Use `strcat' instead unless you can guarantee you won't violate that."
` ( concatenate 'string
,@ strings ) )
( defmacro until ( stmt )
"Repeat stmt until its return is not NIL, then return that value."
` ( let ( ( ret nil ) )
( loop while ( null ( setf ret , stmt ) ) )
ret ) )
( defmacro popor ( li or )
"If li is list, pop it, else return or"
` ( if ( atom , li ) , or
( pop , li ) ) )
( defun rand-in ( l &key ( random #' random ) )
"Random member of, slide right if nil"
"Pretty sure this doesn't work"
( let ( ( rng ( funcall random ( list-length l ) ) ) )
( let ( ( nl ( nthcdr rng l ) ) )
( until ( pop nl ) ) ) ) )
( defun regex-replace-many ( str matches replwith )
"Replace list of regexes with list of new string"
( let ( ( ret str ) )
( loop for match in matches
for repl in replwith
do ( setf ret ( cl-ppcre:regex-replace-all match ret repl ) ) ) ) )
( defun in-range ( num r s )
( and ( >= num r )
( <= num s ) ) )
( defun format-string ( fmt &rest r )
"Like sprintf I guess"
( with-output-to-string ( stream )
( apply #' format ` ( , stream , fmt . , r ) ) ) )
( defun get-all-symbols ( )
"Gets all symbols"
( let ( ( lst ' ( ) ) )
( do-all-symbols ( s lst )
( push s lst ) )
lst ) )
( defun symbol-match ( scan &optional ( symbols nil ) )
"Return all symbols whose names match regex `scan'. If symbols are not provided, get them all."
( let ( ( symbols ( val-if-or symbols #' true
( get-all-symbols ) ) ) )
( where #' ( lambda ( x ) ( cl-ppcre:scan scan ( write-to-string x ) ) )
symbols ) ) )
( defun index ( i max )
"Looping index"
( if ( < i 0 )
( index ( + max i ) max )
( mod i max ) ) )
( defun slice-list ( seq start &optional ( end -1 ) )
"Like JS slice() for list"
( let ( ( start ( index start ( length seq ) ) )
( end ( index end ( length seq ) ) ) )
( rplacd ( nthcdr end seq ) nil )
( nthcdr start seq ) ) )
( defun slice ( seq start &optional ( end -1 ) )
"Like JS slice()?"
( let ( ( start ( index start ( length seq ) ) )
( end ( index end ( 1+ ( length seq ) ) ) ) )
( subseq seq start end ) ) )
( defun flatten-top-level ( li )
"'( (1 2) 3 4 (5 6 7) (8) ((9 10))) -> ( 1 2 3 4 5 6 7 8 (9 10))"
( mapcan #' ( lambda ( x )
( if ( atom x ) ( list x ) x ) )
li ) )
( defun flatten ( li )
"'( (1 2) 3 4 (5 6 7) (8) ((9 10))) -> ( 1 2 3 4 5 6 7 8 9 10)"
( mapcan #' ( lambda ( x )
( if ( atom x )
( list x )
( flatten x ) ) )
li ) )
( defun strjoin ( delim &rest strs )
"Join strings with deliminator"
( let ( ( strs ( flatten-top-level strs ) ) )
( apply #' strcat
( slice
( mapcan #' ( lambda ( x )
( list x delim ) )
strs )
0 -2 ) ) ) )
( defun export-struct ( struct &optional ( symbols nil ) ) ;;XXX: Exporting make-* does not check for $
"Export all symbols relating to `struct'"
( mapc #' export ( symbol-match ( strcat "^(MAKE-)?" ( write-to-string struct ) "-?" ) symbols ) ) )
( defun -export*-struct ( structs &optional ( symbols nil ) ) ;;XXX
( mapc #' export ( symbol-match
( strcat
"^(MAKE-)?("
( strjoin "|" ( mapcar #' write-to-string structs ) )
")-?" )
symbols ) ) )
( defmacro export*-struct ( &rest structs )
"Export all symbols relating to multiple structs"
` ( -export*-struct ' ( ,@ structs ) ) )
( defun mapn ( lam &rest lists )
"Map and return last"
( let ( ( ret ' ( ) ) )
( mapc #' ( lambda ( x )
( setf ret ( funcall lam x ) ) )
( flatten-top-level lists ) )
ret ) )
( defun cyclic ( list )
"Simple circular list"
( cdr ( rplacd ( last list ) list ) ) )
( defun map1 ( lam &rest lists )
"Map and return first"
( let ( ( ret ' ( ) )
( change t ) )
( mapc #' ( lambda ( x )
( if change
( progn
( setf ret ( funcall lam x ) )
( setf change nil ) )
( funcall lam x ) ) )
( flatten-top-level lists ) )
ret ) )
( defun mapnth ( lam n &rest args )
"Map and return nth or nil (second value t if match found)"
( let ( ( index 0 )
( ret ' ( ) )
( match nil ) )
( mapc #' ( lambda ( x )
( if ( = n index )
( progn ( setf ret ( funcall lam x ) ) ( setf match t ) )
( funcall lam x ) )
( incf index ) )
( flatten-top-level args ) )
( values ret match ) ) )
( defun mapv ( lam &rest args )
"Map and return values()"
( apply #' values
( mapcar lam ( flatten-top-level args ) ) ) )
( defmacro lexical-boundp ( lex )
"XXX: Use (declare (special ...)) instead"
` ( when ( ignore-errors , lex ) t ) )
;; --- progressive evals
( defmacro progex ( funcs expr )
"run funcs on expr, return specified"
( let ( ( name ( gensym ) ) )
` ( let ( ( , name , expr ) )
( mapcar #' ( lambda ( x ) ( funcall x , name ) ) , funcs )
, name ) ) )
( defmacro progen ( &rest things )
"mapn eval things"
` ( mapn #' eval ' ( ,@ things ) ) )
( defmacro proge1 ( &rest things )
"map1 eval things"
` ( map1 #' eval ' ( ,@ things ) ) )
( defmacro progenth ( n &rest things )
"mapnth eval n things"
` ( mapnth #' eval , n ' ( ,@ things ) ) )
( defmacro progev ( &rest things )
"mapv eval things"
` ( mapv #' eval ' ( ,@ things ) ) )
( defmacro progel ( &rest things )
"mapcar eval things"
` ( mapcar #' eval ' ( ,@ things ) ) )
( defmacro progenc ( &rest things )
"mapcan eval things"
` ( mapcan #' eval ' ( ,@ things ) ) )
( defmacro yield-return ( &rest things )
"Create yield block, returns last of push()ed outputs of yield() (so, last is first etc)"
` ( let ( ( --yield-vars ' ( ) )
( --yield-var nil ) )
( declare ( special --yield-vars
--yield-var ) )
,@ things
( apply #' values --yield-var ) ) )
( defmacro yield ( value )
"Yield return value `value' if in yield-return(...) block."
` ( when ( boundp '--yield-vars )
( setf --yield-var ( multiple-value-list , value ) )
( push ( car --yield-var ) --yield-vars ) ) )
( defparameter *yield-global-vars* ' ( ) )
( defmacro yield-return-global ( name &rest things )
"Like yield-return but stores values by key in alist and is accessable outside of current lexenv"
` ( car ( yield-return
( push ( cons , name ' ( ) ) *yield-global-vars* )
,@ things
( yield ( cdr ( assoc , name *yield-global-vars* ) ) )
( setf *yield-global-vars* ( remove , name *yield-global-vars* :key #' car :count 1 ) ) ) ) )
( defmacro yield-global ( name value )
` ( when ( assoc , name *yield-global-vars* )
( push , value ( cdr ( assoc , name *yield-global-vars* ) ) ) ) )
;; ---
( defmacro push-unique ( thing things &key ( key nil ) ( test #' eql ) )
"Push if not member"
` ( let ( ( lex-thing , thing ) )
( if ( member lex-thing , things :key , key :test , test )
( values , things nil )
( values ( push lex-thing , things ) t ) ) ) )
( defmacro import* ( &rest args )
"Import all symbols"
( cons 'progn ( mapcan #' ( lambda ( x ) ` ( ( import ',x ) ) ) args ) ) )
( defmacro shadowing-import* ( &rest args )
"Import all symbols (shadowing)"
( cons 'progn ( mapcan #' ( lambda ( x ) ` ( ( shadowing-import ',x ) ) ) args ) ) )
( defmacro import*! ( &rest args )
"Map eval then import all returns"
` ( mapc #' import ( progel , args ) ) )
( defmacro shadowing-import*! ( &rest args )
"Map eval then import all returns (shadowing)"
` ( mapc #' shadowing-import ( progel , args ) ) )
( defmacro import*-from ( package &rest args )
"Import all symbols from package. NOTE: You shouldn't prefix the symbols with the package name"
( let ( ( ret ( mapcar #' ( lambda ( x ) ( read-from-string ( strcat ( subseq ( write-to-string package ) 1 ) ":" ( write-to-string x ) ) ) ) args ) ) )
` ( shadowing-import* @,ret ) ) )
;(defun restrain-index (i max)
;
; (if nil
; (if (>= i max) (1- max)
; (if (< i 0) 0
; i))
; i))
( defun many-equals ( items &key ( test #' eql ) )
"For some reason equality comparers don't like more than 2 args"
( let ( ( comp ( car items ) ) )
( labels ( ( compare ( x to )
( when ( null x ) t )
( when ( funcall test ( car x ) to )
( compare ( cdr x ) to ) ) ) )
( compare ( cdr items ) comp ) ) ) )
( defun many-eql ( &rest items )
( many-equals items :test #' eql ) )
; --- async stuff
( defstruct async-info
thread
handlers
lock )
( defmacro push-handler ( name lam )
"Push new handler to current async-info with name"
"NOTE: Should only be used inside an async() body."
` ( bt:with-lock-held
( ( async-info-lock current-async-info ) )
( push ( cons , name , lam )
( async-info-handlers current-async-info ) ) ) )
( defmacro async ( &rest form )
"Run form(s) async"
` ( let ( ( current-async-info ( make-async-info ) ) )
( setf ( async-info-handlers current-async-info ) nil )
( setf ( async-info-lock current-async-info ) ( bt:make-lock ) )
( setf ( async-info-thread current-async-info )
( bt:make-thread
#' ( lambda ( )
,@ form ) ) )
current-async-info ) )
( defun async-info-handler ( async name &key ( test 'eql ) )
"Get handler from async-info of name"
( bt:with-lock-held ( ( async-info-lock async ) )
( let ( ( as ( assoc name ( async-info-handlers async ) :test test ) ) )
( and as
( cdr as ) ) ) ) )
( defun wait ( handle )
"Wait on async()"
( if ( async-info-p handle )
( wait ( async-info-thread handle ) )
( bt:join-thread handle ) ) )
( defun async-kill ( handle )
"Kill async()"
( if ( async-info-p handle )
( async-kill ( async-info-thread handle ) )
( bt:destroy-thread handle ) ) )
( defun async-alive ( handle )
"Is async() alive"
( if ( async-info-p handle )
( async-alive ( async-info-thread handle ) )
( bt:thread-alive-p handle ) ) )
( defun val ( v ) v )
( defun groupn ( n list )
"Group list into sublists every `n' items."
( let ( ( last nil )
( ret nil ) )
( loop for x in list
for y from 0 below ( length list )
do ( if ( = 0 ( mod y n ) )
( push x last )
( progn
( push x last )
( setf ret ( cons ( reverse last ) ret ) )
( setf last nil ) ) ) )
( reverse ret ) ) )
; --- reader macros
( defun sexpr-reader ( stream char &key ( func 'val ) ( unset t ) ( keep-char t ) )
"Read next token only if S expression, else return as is"
( if ( char= ( peek-char t stream t nil t ) #\( )
( values ( funcall func ( read stream t nil t ) ) t )
( let ( ( *readtable* ( copy-readtable ) ) )
( and unset ( set-macro-character char nil ) )
( if keep-char
( values ( read-from-string ( strcat ( string char ) ( write-to-string ( read stream t nil t ) ) ) ) nil )
( values ( read stream t nil t ) nil ) ) ) ) )
( defun not-reader ( stream char )
( declare ( ignore char ) )
( list ( quote not ) ( read stream t nil t ) ) )
( defun read-delimiter ( stream char )
( declare ( ignore stream char ) ) )
( defun read-next-until ( stream char )
( if ( char= ( peek-char t stream t nil t ) char )
( progn
( read-char stream t nil t ) nil )
( read stream t nil t ) ) )
( defun export-reader ( stream char )
( declare ( ignore char ) )
( loop for next = ( read-next-until stream #\] )
while next
collect next into objects
finally ( return ` ( defexport ,@ objects ) ) ) )
( defun top-level-reader ( stream char )
( multiple-value-bind ( thing okay ) ( sexpr-reader stream char )
( if okay
( append ( list 'eval-when ' ( :compile-toplevel :load-toplevel :execute ) ) ( list thing ) )
thing ) ) )
( defun async-reader ( stream char )
( multiple-value-bind ( thing okay ) ( sexpr-reader stream char )
( if okay
( cons 'async ( list thing ) )
thing ) ) )
( defun lambda-reader ( stream char )
( declare ( ignore char ) )
` ( lambda ( ) , ( read stream t nil t ) ) )
( defmacro enable-all-readers ( )
"Turn on reader macros"
' ( eval-when ( :compile-toplevel :load-toplevel :execute )
( push *readtable* *old-readtables* )
( setq *readtable* ( copy-readtable ) )
( set-macro-character #\[ 'export-reader ) ;"Exports all in brackets []"
( set-macro-character #\] 'read-delimiter )
( set-macro-character #\$ 'async-reader ) ;"Run statement in seperate thread"
( set-macro-character #\¬ 'not-reader ) ;"Negates next statement"
( set-macro-character #\£ 'lambda-reader ) ;"Wrap statement in lambda"
( set-macro-character #\€ 'top-level-reader ) ) ) ;"Run at compile,load and execute"
( defmacro disable-all-readers ( )
"Turn off reader macros"
' ( eval-when ( :compile-toplevel :load-toplevel :execute )
( setq *readtable* ( pop *old-readtables* ) ) ) )
; ((defun map-parallel (func seq &key (map #'mapcar) (split 0.25) (debug nil)) ;;; TODO: make this work lol
; (flet ((dprint (x) (when debug (format t "~S~%" x)) x ))
; "Map over list in parallel"
; (let* ((step (floor (* split (list-length seq))))
; (threads (val-if-or (ceiling (/ 1 split))
; #'(lambda (val)
; (< val step))
; 0)))
; (if (< threads 2)
; (funcall map func seq) ;; no splits
; (let ((threads '())
; (no-threads threads)
; (outputs (make-list threads))
; (left '()))
; (loop for i from 0 below no-threads
; for start from 0 below (list-length seq) by step
; do (progn
; (push (bt:make-thread
; #'(lambda ()
; ;(dprint (list i start (restrain-index (+ step start) (list-length seq) )))
; (rplaca (nthcdr i outputs)
; (funcall map func (slice seq start (+ (1- step) start))))))
; threads)))
; (setf left
; (when (> (mod (list-length seq) step) 0)
; (funcall map func (slice seq (* no-threads step) (+ (* no-threads step) (mod (list-length seq) step))))))
;
; (loop while (apply #'= (cons 0 (mapcar #'(lambda (x) (if (bt:thread-alive-p x) 1 0)) threads))) do
; (dprint
; (mapcar #'bt:thread-alive-p
; threads)))
; (apply #'nconc (append outputs left)))))))
;
;(defun map-parallel-test (&key (length 10001))
; (map-parallel
; #'(lambda (x)
; x)
; (make-list length :initial-element 1)
; :debug t))
; --- others
( defmacro switch ( value &body conds )
"Cond `eql' for value to each first element of `conds', with the result as the 2nd element. If `conds' is an atom, it is treated as the default condition"
( let* ( ( value-name ( gensym ) )
( exprs ( mapcar #' ( lambda ( pair )
( if ( atom pair )
` ( t , pair )
` ( ( eql , value-name , ( car pair ) ) , ( cadr pair ) ) ) ) conds ) ) )
` ( let ( ( , value-name , value ) )
, ( cons 'cond exprs ) ) ) )
( defun split-string ( string &optional sep )
"Split a string by this seperator (or whitespace, if not provided)"
( let* ( ( sep ( or ( switch sep
( #\Newline "[\\n\\f\\r]" )
( #\Space " " )
( #\Backspace "\\b" )
( #\Tab "\\t" )
( #\Linefeed "\\n" )
( #\Page "\\f" ) ; ???
( #\Return "\\r" )
;(#\Rubout wtf even is this???
( nil "\\s" )
nil )
( cl-ppcre:quote-meta-chars sep ) ) )
( lst ( cl-ppcre:split sep string ) ) )
( values ( where #' ( lambda ( str ) ( > ( length str ) 0 ) ) lst )
sep ) ) )
( defmacro popto ( li val &key ( test #' eql ) )
"pop() list <li> until (car li) is equal to <val>, return elements pop()ed in new list"
` ( loop while ( not ( funcall , test ( car , li ) , val ) )
collect ( pop , li ) ) )
( defmacro popn ( li n )
"pop() list <li> <n> times, return elements pop()ed in a new list."
( if ( numberp n )
( list 'let ' ( ( tmp 'nil ) )
( apply #' list 'progn
( loop for x from 1 to n
collect ` ( setf tmp ( cons ( pop , li ) tmp ) ) ) )
' ( reverse tmp ) )
` ( loop for x from 1 to , n collect ( pop , li ) ) ) )
( defun make-paged-vector ( blocksize &key ( element-type 'integer ) )
"Vector that increases size in blocks"
( list ( make-array blocksize :element-type element-type :fill-pointer 0 :adjustable t ) blocksize 0 1 ) )
( defun paged-vector<-size ( vec ) ( caddr vec ) )
( defun paged-vector<-blocksize ( vec ) ( cadr vec ) )
( defun paged-vector<-blocks ( vec ) ( cadddr vec ) )
( defmacro paged-vector->push ( vec elem )
"add <elem> to end, extending if needed"
` ( if ( >= ( 1+ ( mod ( paged-vector<-size , vec ) ( paged-vector<-blocksize , vec ) ) ) ( paged-vector<-blocksize , vec ) )
( progn
( adjust-array ( car , vec )
( * ( 1+ ( paged-vector<-blocks , vec ) )
( paged-vector<-blocksize , vec ) ) )
( incf ( cadddr , vec ) )
( incf ( caddr , vec ) )
( vector-push , elem ( car , vec ) )
, vec )
( progn ( incf ( caddr , vec ) ) ( vector-push , elem ( car , vec ) ) , vec ) ) )
( defun make-paged-vector-s ( elements blocksize )
"make-paged-vector with default elements"
( let ( ( out ( make-paged-vector blocksize ) ) )
( mapc #' ( lambda ( x ) ( paged-vector->push out x ) ) elements ) out ) )
( defmacro paged-vector<- ( vec ) ` ( car , vec ) )
) ;; -- end export