/
boot.janet
3359 lines (2992 loc) · 97.2 KB
/
boot.janet
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
# The core janet library
# Copyright 2020 © Calvin Rose
###
###
### Macros and Basic Functions
###
###
(def root-env "The root environment used to create environments with (make-env)" _env)
(def defn :macro
```
(defn name & more)
Define a function. Equivalent to (def name (fn name [args] ...)).
```
(fn defn [name & more]
(def len (length more))
(def modifiers @[])
(var docstr "")
(def fstart
(fn recur [i]
(def {i ith} more)
(def t (type ith))
(if (= t :tuple)
i
(do
(if (= t :string)
(set docstr ith)
(array/push modifiers ith))
(if (< i len) (recur (+ i 1)))))))
(def start (fstart 0))
(def args (in more start))
# Add function signature to docstring
(var index 0)
(def arglen (length args))
(def buf (buffer "(" name))
(while (< index arglen)
(buffer/push-string buf " ")
(buffer/format buf "%j" (in args index))
(set index (+ index 1)))
(array/push modifiers (string buf ")\n\n" docstr))
# Build return value
~(def ,name ,;modifiers (fn ,name ,;(tuple/slice more start)))))
(defn defmacro :macro
"Define a macro."
[name & more]
(apply defn name :macro more))
(defmacro defmacro-
"Define a private macro that will not be exported."
[name & more]
(apply defn name :macro :private more))
(defmacro defn-
"Define a private function that will not be exported."
[name & more]
(apply defn name :private more))
(defmacro def-
"Define a private value that will not be exported."
[name & more]
~(def ,name :private ,;more))
(defmacro var-
"Define a private var that will not be exported."
[name & more]
~(var ,name :private ,;more))
(defn defglobal
"Dynamically create a global def."
[name value]
(def name* (symbol name))
(setdyn name* @{:value value})
nil)
(defn varglobal
"Dynamically create a global var."
[name init]
(def name* (symbol name))
(setdyn name* @{:ref @[init]})
nil)
# Basic predicates
(defn nan? "Check if x is NaN" [x] (not= x x))
(defn even? "Check if x is even." [x] (= 0 (mod x 2)))
(defn odd? "Check if x is odd." [x] (= 1 (mod x 2)))
(defn number? "Check if x is a number." [x] (= (type x) :number))
(defn fiber? "Check if x is a fiber." [x] (= (type x) :fiber))
(defn string? "Check if x is a string." [x] (= (type x) :string))
(defn symbol? "Check if x is a symbol." [x] (= (type x) :symbol))
(defn keyword? "Check if x is a keyword." [x] (= (type x) :keyword))
(defn buffer? "Check if x is a buffer." [x] (= (type x) :buffer))
(defn function? "Check if x is a function (not a cfunction)." [x]
(= (type x) :function))
(defn cfunction? "Check if x a cfunction." [x] (= (type x) :cfunction))
(defn table? "Check if x a table." [x] (= (type x) :table))
(defn struct? "Check if x a struct." [x] (= (type x) :struct))
(defn array? "Check if x is an array." [x] (= (type x) :array))
(defn tuple? "Check if x is a tuple." [x] (= (type x) :tuple))
(defn boolean? "Check if x is a boolean." [x] (= (type x) :boolean))
(defn bytes? "Check if x is a string, symbol, keyword, or buffer." [x]
(def t (type x))
(if (= t :string) true (if (= t :symbol) true (if (= t :keyword) true (= t :buffer)))))
(defn dictionary? "Check if x is a table or struct." [x]
(def t (type x))
(if (= t :table) true (= t :struct)))
(defn indexed? "Check if x is an array or tuple." [x]
(def t (type x))
(if (= t :array) true (= t :tuple)))
(defn truthy? "Check if x is truthy." [x] (if x true false))
(defn true? "Check if x is true." [x] (= x true))
(defn false? "Check if x is false." [x] (= x false))
(defn nil? "Check if x is nil." [x] (= x nil))
(defn empty? "Check if xs is empty." [xs] (= (length xs) 0))
(def idempotent?
```
(idempotent? x)
Check if x is a value that evaluates to itself when compiled.
```
(do
(def non-atomic-types
{:array true
:tuple true
:table true
:buffer true
:struct true})
(fn idempotent? [x] (not (in non-atomic-types (type x))))))
# C style macros and functions for imperative sugar. No bitwise though.
(defn inc "Returns x + 1." [x] (+ x 1))
(defn dec "Returns x - 1." [x] (- x 1))
(defmacro ++ "Increments the var x by 1." [x] ~(set ,x (,+ ,x ,1)))
(defmacro -- "Decrements the var x by 1." [x] ~(set ,x (,- ,x ,1)))
(defmacro += "Increments the var x by n." [x n] ~(set ,x (,+ ,x ,n)))
(defmacro -= "Decrements the var x by n." [x n] ~(set ,x (,- ,x ,n)))
(defmacro *= "Shorthand for (set x (* x n))." [x n] ~(set ,x (,* ,x ,n)))
(defmacro /= "Shorthand for (set x (/ x n))." [x n] ~(set ,x (,/ ,x ,n)))
(defmacro %= "Shorthand for (set x (% x n))." [x n] ~(set ,x (,% ,x ,n)))
(defn assert
"Throw an error if x is not truthy."
[x &opt err]
(if x x (error (if err err "assert failure"))))
(defn errorf
"A combination of error and string/format. Equivalent to (error (string/format fmt ;args))"
[fmt & args]
(error (string/format fmt ;args)))
(defmacro default
`Define a default value for an optional argument.
Expands to (def sym (if (= nil sym) val sym))`
[sym val]
~(def ,sym (if (= nil ,sym) ,val ,sym)))
(defmacro comment
"Ignores the body of the comment."
[&])
(defmacro if-not
"Shorthand for (if (not condition) else then)."
[condition then &opt else]
~(if ,condition ,else ,then))
(defmacro when
"Evaluates the body when the condition is true. Otherwise returns nil."
[condition & body]
~(if ,condition (do ,;body)))
(defmacro unless
"Shorthand for (when (not condition) ;body). "
[condition & body]
~(if ,condition nil (do ,;body)))
(defmacro cond
`Evaluates conditions sequentially until the first true condition
is found, and then executes the corresponding body. If there are an
odd number of forms, the last expression is executed if no forms
are matched. If there are no matches, return nil.`
[& pairs]
(defn aux [i]
(def restlen (- (length pairs) i))
(if (= restlen 0) nil
(if (= restlen 1) (in pairs i)
(tuple 'if (in pairs i)
(in pairs (+ i 1))
(aux (+ i 2))))))
(aux 0))
(defmacro case
`Select the body that equals the dispatch value. When pairs
has an odd number of arguments, the last is the default expression.
If no match is found, returns nil.`
[dispatch & pairs]
(def atm (idempotent? dispatch))
(def sym (if atm dispatch (gensym)))
(defn aux [i]
(def restlen (- (length pairs) i))
(if (= restlen 0) nil
(if (= restlen 1) (in pairs i)
(tuple 'if (tuple = sym (in pairs i))
(in pairs (+ i 1))
(aux (+ i 2))))))
(if atm
(aux 0)
(tuple 'do
(tuple 'def sym dispatch)
(aux 0))))
(defmacro let
`Create a scope and bind values to symbols. Each pair in bindings is
assigned as if with def, and the body of the let form returns the last
value.`
[bindings & body]
(if (odd? (length bindings)) (error "expected even number of bindings to let"))
(def len (length bindings))
(var i 0)
(var accum @['do])
(while (< i len)
(def {i k (+ i 1) v} bindings)
(array/push accum (tuple 'def k v))
(+= i 2))
(array/concat accum body)
(tuple/slice accum 0))
(defmacro try
`Try something and catch errors. Body is any expression,
and catch should be a form with the first element a tuple. This tuple
should contain a binding for errors and an optional binding for
the fiber wrapping the body. Returns the result of body if no error,
or the result of catch if an error.`
[body catch]
(let [[[err fib]] catch
f (gensym)
r (gensym)]
~(let [,f (,fiber/new (fn [] ,body) :ie)
,r (,resume ,f)]
(if (,= (,fiber/status ,f) :error)
(do (def ,err ,r) ,(if fib ~(def ,fib ,f)) ,;(tuple/slice catch 1))
,r))))
(defmacro protect
`Evaluate expressions, while capturing any errors. Evaluates to a tuple
of two elements. The first element is true if successful, false if an
error, and the second is the return value or error.`
[& body]
(let [f (gensym) r (gensym)]
~(let [,f (,fiber/new (fn [] ,;body) :ie)
,r (,resume ,f)]
[(,not= :error (,fiber/status ,f)) ,r])))
(defmacro and
`Evaluates to the last argument if all preceding elements are truthy, otherwise
evaluates to the first falsey argument.`
[& forms]
(var ret true)
(def len (length forms))
(var i len)
(while (> i 0)
(-- i)
(def v (in forms i))
(set ret (if (= ret true)
v
(if (idempotent? v)
['if v ret v]
(do (def s (gensym))
['if ['def s v] ret s])))))
ret)
(defmacro or
`Evaluates to the last argument if all preceding elements are falsey, otherwise
evaluates to the first truthy element.`
[& forms]
(def len (length forms))
(var i (- len 1))
(var ret (in forms i))
(while (> i 0)
(-- i)
(def fi (in forms i))
(set ret (if (idempotent? fi)
(tuple 'if fi fi ret)
(do
(def $fi (gensym))
(tuple 'do (tuple 'def $fi fi)
(tuple 'if $fi $fi ret))))))
ret)
(defmacro with-syms
"Evaluates body with each symbol in syms bound to a generated, unique symbol."
[syms & body]
(var i 0)
(def len (length syms))
(def accum @[])
(while (< i len)
(array/push accum (in syms i) [gensym])
(++ i))
~(let (,;accum) ,;body))
(defmacro defer
`Run form unconditionally after body, even if the body throws an error.
Will also run form if a user signal 0-4 is received.`
[form & body]
(with-syms [f r]
~(do
(def ,f (,fiber/new (fn [] ,;body) :ti))
(def ,r (,resume ,f))
,form
(if (= (,fiber/status ,f) :dead)
,r
(,propagate ,r ,f)))))
(defmacro edefer
`Run form after body in the case that body terminates abnormally (an error or user signal 0-4).
Otherwise, return last form in body.`
[form & body]
(with-syms [f r]
~(do
(def ,f (,fiber/new (fn [] ,;body) :ti))
(def ,r (,resume ,f))
(if (= (,fiber/status ,f) :dead)
,r
(do ,form (,propagate ,r ,f))))))
(defmacro prompt
`Set up a checkpoint that can be returned to. Tag should be a value
that is used in a return statement, like a keyword.`
[tag & body]
(with-syms [res target payload fib]
~(do
(def ,fib (,fiber/new (fn [] [,tag (do ,;body)]) :i0))
(def ,res (,resume ,fib))
(def [,target ,payload] ,res)
(if (,= ,tag ,target)
,payload
(,propagate ,res ,fib)))))
(defmacro chr
`Convert a string of length 1 to its byte (ascii) value at compile time.`
[c]
(unless (and (string? c) (= (length c) 1))
(error (string/format "expected string of length 1, got %v" c)))
(c 0))
(defmacro label
`Set a label point that is lexically scoped. Name should be a symbol
that will be bound to the label.`
[name & body]
~(do
(def ,name @"")
,(apply prompt name body)))
(defn return
"Return to a prompt point."
[to &opt value]
(signal 0 [to value]))
(defmacro with
`Evaluate body with some resource, which will be automatically cleaned up
if there is an error in body. binding is bound to the expression ctor, and
dtor is a function or callable that is passed the binding. If no destructor
(dtor) is given, will call :close on the resource.`
[[binding ctor dtor] & body]
~(do
(def ,binding ,ctor)
,(apply defer [(or dtor :close) binding] body)))
(defmacro when-with
`Similar to with, but if binding is false or nil, returns
nil without evaluating the body. Otherwise, the same as with.`
[[binding ctor dtor] & body]
~(if-let [,binding ,ctor]
,(apply defer [(or dtor :close) binding] body)))
(defmacro if-with
`Similar to with, but if binding is false or nil, evaluates
the falsey path. Otherwise, evaluates the truthy path. In both cases,
ctor is bound to binding.`
[[binding ctor dtor] truthy &opt falsey]
~(if-let [,binding ,ctor]
,(apply defer [(or dtor :close) binding] [truthy])
,falsey))
(defn- for-var-template
[i start stop step comparison delta body]
(with-syms [s]
(def st (if (idempotent? step) step (gensym)))
(def loop-body
~(while (,comparison ,i ,s)
,;body
(set ,i (,delta ,i ,st))))
~(do
(var ,i ,start)
(def ,s ,stop)
,;(if (= st step) [] [~(def ,st ,step)])
,(if (and (number? st) (> st 0))
loop-body
~(if (,> ,st 0) ,loop-body)))))
(defn- for-template
[binding start stop step comparison delta body]
(def i (gensym))
(for-var-template i start stop step comparison delta
[~(def ,binding ,i) ;body]))
(defn- check-indexed [x]
(if (indexed? x)
x
(error (string "expected tuple for range, got " x))))
(defn- range-template
[binding object rest op comparison]
(let [[start stop step] (check-indexed object)]
(for-template binding start stop (or step 1) comparison op [rest])))
(defn- each-template
[binding inx kind body]
(with-syms [k]
(def ds (if (idempotent? inx) inx (gensym)))
~(do
,(unless (= ds inx) ~(def ,ds ,inx))
(var ,k (,next ,ds nil))
(while (,not= nil ,k)
(def ,binding
,(case kind
:each ~(,in ,ds ,k)
:keys k
:pairs ~(,tuple ,k (,in ,ds ,k))))
,;body
(set ,k (,next ,ds ,k))))))
(defn- iterate-template
[binding expr body]
(with-syms [i]
~(do
(var ,i nil)
(while (set ,i ,expr)
(def ,binding ,i)
,body))))
(defn- loop-fiber-template
[binding expr body]
(with-syms [f s]
(def ds (if (idempotent? binding) binding (gensym)))
~(let [,f ,expr]
(while true
(def ,ds (,resume ,f))
(if (= :dead (,fiber/status ,f)) (break))
,;(if (= ds binding) [] [~(def ,binding ,ds)])
,;body))))
(defn- loop1
[body head i]
# Terminate recursion
(when (<= (length head) i)
(break ~(do ,;body)))
(def {i binding
(+ i 1) verb} head)
# 2 term expression
(when (keyword? binding)
(break
(let [rest (loop1 body head (+ i 2))]
(case binding
:until ~(do (if ,verb (break) nil) ,rest)
:while ~(do (if ,verb nil (break)) ,rest)
:let ~(let ,verb (do ,rest))
:after ~(do ,rest ,verb nil)
:before ~(do ,verb ,rest nil)
:repeat (with-syms [iter]
~(do (var ,iter ,verb) (while (> ,iter 0) ,rest (-- ,iter))))
:when ~(when ,verb ,rest)
(error (string "unexpected loop modifier " binding))))))
# 3 term expression
(def {(+ i 2) object} head)
(let [rest (loop1 body head (+ i 3))]
(case verb
:range (range-template binding object rest + <)
:range-to (range-template binding object rest + <=)
:down (range-template binding object rest - >)
:down-to (range-template binding object rest - >=)
:keys (each-template binding object :keys [rest])
:pairs (each-template binding object :pairs [rest])
:in (each-template binding object :each [rest])
:iterate (iterate-template binding object rest)
:generate (loop-fiber-template binding object [rest])
(error (string "unexpected loop verb " verb)))))
(defmacro forv
`Do a c style for loop for side effects. The iteration variable i
can be mutated in the loop, unlike normal for. Returns nil.`
[i start stop & body]
(for-var-template i start stop 1 < + body))
(defmacro for
"Do a c style for loop for side effects. Returns nil."
[i start stop & body]
(for-template i start stop 1 < + body))
(defmacro eachk
"Loop over each key in ds. Returns nil."
[x ds & body]
(each-template x ds :keys body))
(defmacro eachp
"Loop over each (key, value) pair in ds. Returns nil."
[x ds & body]
(each-template x ds :pairs body))
(defmacro eachy
`Resume a fiber in a loop until it has errored or died. Evaluate the body
of the loop with binding set to the yielded value.`
[x fiber & body]
(loop-fiber-template x fiber body))
(defmacro repeat
"Evaluate body n times. If n is negative, body will be evaluated 0 times. Evaluates to nil."
[n & body]
(with-syms [iter]
~(do (var ,iter ,n) (while (> ,iter 0) ,;body (-- ,iter)))))
(defmacro forever
"Evaluate body forever in a loop, or until a break statement."
[& body]
~(while true ,;body))
(defmacro each
"Loop over each value in ds. Returns nil."
[x ds & body]
(each-template x ds :each body))
(defmacro loop
```
A general purpose loop macro. This macro is similar to the Common Lisp
loop macro, although intentionally much smaller in scope.
The head of the loop should be a tuple that contains a sequence of
either bindings or conditionals. A binding is a sequence of three values
that define something to loop over. They are formatted like:
binding :verb object/expression
Where `binding` is a binding as passed to def, `:verb` is one of a set of
keywords, and `object` is any expression. The available verbs are:
* :iterate -- repeatedly evaluate and bind to the expression while it is
truthy.
* :range -- loop over a range. The object should be a two-element tuple with
a start and end value, and an optional positive step. The range is half
open, [start, end).
* :range-to -- same as :range, but the range is inclusive [start, end].
* :down -- loop over a range, stepping downwards. The object should be a
two-element tuple with a start and (exclusive) end value, and an optional
(positive!) step size.
* :down-to -- same :as down, but the range is inclusive [start, end].
* :keys -- iterate over the keys in a data structure.
* :pairs -- iterate over the key-value pairs as tuples in a data structure.
* :in -- iterate over the values in a data structure.
* :generate -- iterate over values yielded from a fiber. Can be paired with
the generator function for the producer/consumer pattern.
`loop` also accepts conditionals to refine the looping further. Conditionals are of
the form:
:modifier argument
where `:modifier` is one of a set of keywords, and `argument` is keyword-dependent.
`:modifier` can be one of:
* `:while expression` - breaks from the loop if `expression` is falsey.
* `:until expression` - breaks from the loop if `expression` is truthy.
* `:let bindings` - defines bindings inside the loop as passed to the `let` macro.
* `:before form` - evaluates a form for a side effect before the next inner loop.
* `:after form` - same as `:before`, but the side effect happens after the next inner loop.
* `:repeat n` - repeats the next inner loop `n` times.
* `:when condition` - only evaluates the loop body when condition is true.
The `loop` macro always evaluates to nil.
```
[head & body]
(loop1 body head 0))
(defmacro seq
`Similar to loop, but accumulates the loop body into an array and returns that.
See loop for details.`
[head & body]
(def $accum (gensym))
~(do (def ,$accum @[]) (loop ,head (array/push ,$accum (do ,;body))) ,$accum))
(defmacro generate
`Create a generator expression using the loop syntax. Returns a fiber
that yields all values inside the loop in order. See loop for details.`
[head & body]
~(fiber/new (fn [] (loop ,head (yield (do ,;body)))) :yi))
(defmacro coro
"A wrapper for making fibers. Same as (fiber/new (fn [] ;body) :yi)."
[& body]
(tuple fiber/new (tuple 'fn '[] ;body) :yi))
(defmacro- undef
"Remove binding from root-env"
[& syms]
~(do ,;(seq [s :in syms] ~(put root-env ',s nil))))
(undef _env)
(undef loop1 check-indexed for-template for-var-template iterate-template
each-template range-template loop-fiber-template)
(defn sum
"Returns the sum of xs. If xs is empty, returns 0."
[xs]
(var accum 0)
(each x xs (+= accum x))
accum)
(defn mean
"Returns the mean of xs. If empty, returns NaN."
[xs]
(/ (sum xs) (length xs)))
(defn product
"Returns the product of xs. If xs is empty, returns 1."
[xs]
(var accum 1)
(each x xs (*= accum x))
accum)
(defmacro if-let
`Make multiple bindings, and if all are truthy,
evaluate the tru form. If any are false or nil, evaluate
the fal form. Bindings have the same syntax as the let macro.`
[bindings tru &opt fal]
(def len (length bindings))
(if (= 0 len) (error "expected at least 1 binding"))
(if (odd? len) (error "expected an even number of bindings"))
(defn aux [i]
(if (>= i len)
tru
(do
(def bl (in bindings i))
(def br (in bindings (+ 1 i)))
(def atm (idempotent? bl))
(def sym (if atm bl (gensym)))
(if atm
# Simple binding
(tuple 'do
(tuple 'def sym br)
(tuple 'if sym (aux (+ 2 i)) fal))
# Destructured binding
(tuple 'do
(tuple 'def sym br)
(tuple 'if sym
(tuple 'do
(tuple 'def bl sym)
(aux (+ 2 i)))
fal))))))
(aux 0))
(defmacro when-let
"Same as (if-let bindings (do ;body))."
[bindings & body]
~(if-let ,bindings (do ,;body)))
(defn comp
`Takes multiple functions and returns a function that is the composition
of those functions.`
[& functions]
(case (length functions)
0 nil
1 (in functions 0)
2 (let [[f g] functions] (fn [& x] (f (g ;x))))
3 (let [[f g h] functions] (fn [& x] (f (g (h ;x)))))
4 (let [[f g h i] functions] (fn [& x] (f (g (h (i ;x))))))
(let [[f g h i] functions]
(comp (fn [x] (f (g (h (i x)))))
;(tuple/slice functions 4 -1)))))
(defn identity
"A function that returns its first argument."
[x]
x)
(defn complement
"Returns a function that is the complement to the argument."
[f]
(fn [x] (not (f x))))
(defn extreme
`Returns the most extreme value in args based on the function order.
order should take two values and return true or false (a comparison).
Returns nil if args is empty.`
[order args]
(var [ret] args)
(each x args (if (order x ret) (set ret x)))
ret)
(defn max
"Returns the numeric maximum of the arguments."
[& args] (extreme > args))
(defn min
"Returns the numeric minimum of the arguments."
[& args] (extreme < args))
(defn first
"Get the first element from an indexed data structure."
[xs]
(get xs 0))
(defn last
"Get the last element from an indexed data structure."
[xs]
(get xs (- (length xs) 1)))
## Polymorphic comparisons
(defn compare
`Polymorphic compare. Returns -1, 0, 1 for x < y, x = y, x > y respectively.
Differs from the primitive comparators in that it first checks to
see whether either x or y implement a 'compare' method which can
compare x and y. If so it uses that compare method. If not, it
delegates to the primitive comparators.`
[x y]
(or
(when-let [f (get x :compare)] (f x y))
(when-let [f (get y :compare)] (- (f y x)))
(cmp x y)))
(defn- compare-reduce [op xs]
(var r true)
(loop [i :range [0 (- (length xs) 1)]
:let [c (compare (xs i) (xs (+ i 1)))
ok (op c 0)]
:when (not ok)]
(set r false)
(break))
r)
(defn compare=
"Equivalent of '=' but using compare function instead of primitive comparator"
[& xs]
(compare-reduce = xs))
(defn compare<
"Equivalent of '<' but using compare function instead of primitive comparator"
[& xs]
(compare-reduce < xs))
(defn compare<=
"Equivalent of '<=' but using compare function instead of primitive comparator"
[& xs]
(compare-reduce <= xs))
(defn compare>
"Equivalent of '>' but using compare function instead of primitive comparator"
[& xs]
(compare-reduce > xs))
(defn compare>=
"Equivalent of '>=' but using compare function instead of primitive comparator"
[& xs]
(compare-reduce >= xs))
(defn zero? "Check if x is zero." [x] (= (compare x 0) 0))
(defn pos? "Check if x is greater than 0." [x] (= (compare x 0) 1))
(defn neg? "Check if x is less than 0." [x] (= (compare x 0) -1))
(defn one? "Check if x is equal to 1." [x] (= (compare x 1) 0))
(undef compare-reduce)
###
###
### Indexed Combinators
###
###
(defn- sort-part
[a lo hi by]
(def pivot (in a hi))
(var i lo)
(forv j lo hi
(def aj (in a j))
(when (by aj pivot)
(def ai (in a i))
(set (a i) aj)
(set (a j) ai)
(++ i)))
(set (a hi) (in a i))
(set (a i) pivot)
i)
(defn- sort-help
[a lo hi by]
(when (> hi lo)
(def piv (sort-part a lo hi by))
(sort-help a lo (- piv 1) by)
(sort-help a (+ piv 1) hi by))
a)
(defn sort
"Sort an array in-place. Uses quick-sort and is not a stable sort."
[a &opt by]
(sort-help a 0 (- (length a) 1) (or by <)))
(undef sort-part)
(undef sort-help)
(defn sort-by
`Returns a new sorted array that compares elements by invoking
a function on each element and comparing the result with <.`
[f ind]
(sort ind (fn [x y] (< (f x) (f y)))))
(defn sorted
"Returns a new sorted array without modifying the old one."
[ind &opt by]
(sort (array/slice ind) by))
(defn sorted-by
`Returns a new sorted array that compares elements by invoking
a function on each element and comparing the result with <.`
[f ind]
(sorted ind (fn [x y] (< (f x) (f y)))))
(defn reduce
`Reduce, also know as fold-left in many languages, transforms
an indexed type (array, tuple) with a function to produce a value by applying f to
each element in order. f is a function of 2 arguments, (f accum el), where
accum is the initial value and el is the next value in the indexed type ind.
f returns a value that will be used as accum in the next call to f. reduce
returns the value of the final call to f.`
[f init ind]
(var accum init)
(each el ind (set accum (f accum el)))
accum)
(defn reduce2
`The 2-argument version of reduce that does not take an initialization value.
Instead, the first element of the array is used for initialization.`
[f ind]
(var k (next ind))
(if (= nil k) (break nil))
(var res (in ind k))
(set k (next ind k))
(while (not= nil k)
(set res (f res (in ind k)))
(set k (next ind k)))
res)
(defn accumulate
`Similar to reduce, but accumulates intermediate values into an array.
The last element in the array is what would be the return value from reduce.
The init value is not added to the array (the return value will have the same
number of elements as ind).
Returns a new array.`
[f init ind]
(var res init)
(def ret (array/new (length ind)))
(each x ind (array/push ret (set res (f res x))))
ret)
(defn accumulate2
`The 2-argument version of accumulate that does not take an initialization value.
The first value in ind will be added to the array as is, so the length of the
return value will be (length ind).`
[f ind]
(var k (next ind))
(def ret (array/new (length ind)))
(if (= nil k) (break ret))
(var res (in ind k))
(array/push ret res)
(set k (next ind k))
(while (not= nil k)
(set res (f res (in ind k)))
(array/push ret res)
(set k (next ind k)))
ret)
(defn map
`Map a function over every element in an indexed data structure and
return an array of the results.`
[f & inds]
(def ninds (length inds))
(if (= 0 ninds) (error "expected at least 1 indexed collection"))
(var limit (length (in inds 0)))
(forv i 0 ninds
(def l (length (in inds i)))
(if (< l limit) (set limit l)))
(def [i1 i2 i3 i4] inds)
(def res (array/new limit))
(case ninds
1 (forv i 0 limit (set (res i) (f (in i1 i))))
2 (forv i 0 limit (set (res i) (f (in i1 i) (in i2 i))))
3 (forv i 0 limit (set (res i) (f (in i1 i) (in i2 i) (in i3 i))))
4 (forv i 0 limit (set (res i) (f (in i1 i) (in i2 i) (in i3 i) (in i4 i))))
(forv i 0 limit
(def args (array/new ninds))
(forv j 0 ninds (set (args j) (in (in inds j) i)))
(set (res i) (f ;args))))
res)
(defn mapcat
`Map a function over every element in an array or tuple and
use array to concatenate the results.`
[f ind]
(def res @[])
(each x ind
(array/concat res (f x)))
res)
(defn filter
`Given a predicate, take only elements from an array or tuple for
which (pred element) is truthy. Returns a new array.`
[pred ind]
(def res @[])
(each item ind
(if (pred item)
(array/push res item)))
res)
(defn count
`Count the number of items in ind for which (pred item)
is true.`
[pred ind]
(var counter 0)
(each item ind
(if (pred item)
(++ counter)))
counter)
(defn keep
`Given a predicate, take only elements from an array or tuple for
which (pred element) is truthy. Returns a new array of truthy predicate results.`
[pred ind]
(def res @[])
(each item ind
(if-let [y (pred item)]
(array/push res y)))
res)
(defn range
`Create an array of values [start, end) with a given step.
With one argument returns a range [0, end). With two arguments, returns
a range [start, end). With three, returns a range with optional step size.`
[& args]
(case (length args)
1 (do
(def [n] args)
(def arr (array/new n))
(forv i 0 n (put arr i i))
arr)
2 (do
(def [n m] args)
(def arr (array/new (- m n)))
(forv i n m (put arr (- i n) i))
arr)
3 (do
(def [n m s] args)
(cond
(zero? s) @[]
(neg? s) (seq [i :down [n m (- s)]] i)
(seq [i :range [n m s]] i)))
(error "expected 1 to 3 arguments to range")))
(defn find-index
`Find the index of indexed type for which pred is true. Returns nil if not found.`
[pred ind]
(def len (length ind))
(var i 0)
(var going true)
(while (if (< i len) going)
(def item (in ind i))
(if (pred item) (set going false) (++ i)))
(if going nil i))
(defn find
`Find the first value in an indexed collection that satisfies a predicate. Returns
nil if not found. Note there is no way to differentiate a nil from the indexed collection
and a not found. Consider find-index if this is an issue.`
[pred ind]
(def i (find-index pred ind))
(if (= i nil) nil (in ind i)))
(defn index-of