-
Notifications
You must be signed in to change notification settings - Fork 3
/
k.ml
1907 lines (1866 loc) · 102 KB
/
k.ml
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
(* preliminaries & ast ===================================================== *)
type s = int (* symbols *)
type h = (* handles *)
| HRel of s list (* x.y.z *)
| HAbs of s list (* .x.y.z *)
module H = Hashtbl.Make(struct type t = s let equal x y = x=y and hash x = x end) (* symbol-keyed hash table *)
type v = (* verbs. (TODO?:semantic names) *)
| VPlus (* + *)
| VMinus (* - *)
| VStar (* * *)
| VExclaim (* ! *)
| VPercent (* % *)
| VPipe (* | *)
| VAmpersand (* & *)
| VCircumflex (* ^ *)
| VLangle (* < *)
| VRangle (* > *)
| VEquals (* = *)
| VPound (* # *)
| VLodash (* _ *)
| VTilde (* ~ *)
| VDollar (* $ *)
| VQuestion (* ? *)
| VAt (* @ *)
| VDot (* . *)
| VComma (* , *)
| VZeroColon (* 0: *)
| VOneColon (* 1: *)
| VTwoColon (* 2: *)
| VThreeColon (* 3: *)
| VFourColon (* 4: *)
| VFiveColon (* 5: *)
type av = (* adverbs *)
| AVForwardslash | AVForwardslashColon
| AVBackslash | AVBackslashColon
| AVQuote | AVQuoteColon
type f = (* function values (PERF?: optimized form for partially-applied functions, eg FNaryp(n,is,a,f)) *)
| FNilad of (unit -> k)
| FMonad of (k -> k)
| FMonadDyad of (k -> k)*(k -> k -> k)
| FMonadDyadTriad of (k -> k)*(k -> k -> k)*(k -> k -> k -> k)
| FMonadDyadTriadTetrad of (k -> k)*(k -> k -> k)*(k -> k -> k -> k)*(k -> k -> k -> k -> k)
| FDyad of (k -> k -> k)
| FTriad of (k -> k -> k -> k)
| FNary of int * (k array -> k) (* n>=4 *)
and ea = (* arguments (ast) (NOTE/PERF: is it worth it to treat n<=3 separately?) *)
| Ea0
| Ea1 of e
| Ea2 of e * e
| Ea3 of e * e * e
| Ea of e array (* inv:n>=4 *)
and ka = (* arguments (values) *)
| Ka0
| Ka1 of k
| Ka2 of k * k
| Ka3 of k * k * k
| Ka of k array (* inv:n>=4 *)
| Kap of int*k array*int array*int array (* inv. Kap(n,ks,is,js) => |ks|=|is| /\ |is|+|js| = n /\ disjoint(set(is),set(js)) /\ sorted(is) /\ sorted(js) *)
and e = (* expressions *)
| ENil (* empty expression, as in (;). distinct from _n, e.g. ,[_n;2] is application, ,[;2] is partial application *)
| EColon (* assignment in verb form *)
| ELambda of s array * e (* {[x1;x2;...;xN] e} *)
| EApp of e*ea
| EList of e list
| EAdverb of av*e
| EReturn of e (* :e *)
| ESeq of e*e (* e;e' *)
| EIfSimple of e*e*e (* :[i;t;e] *)
| EIfMulti of e array * e array * e (* :[i1;t1;i2;t2;...;iN;tN;e] *)
| EAssign of h*e (* x : e *)
| EAssignMonad of h*e (* x f: *)
| EAssignDyad of h*e*e (* x f: y*)
| EAssignGlobal of h*e (* x :: e *)
| EAssignIndex of h*e array*e (* x[i1;...;iN] : e *)
| EAssignIndexMonad of h*e array*e (* x[i1;...;iN] f: *)
| EAssignIndexDyad of h*e array*e*e (* x[i1;...;iN] f: y *)
| EName of h
| ENameSys of s (* _in, _draw,... *)
| EVerb of v
| EVerbMonadic of v (* v: *)
| EComp of e*e (* e e' (composition) *)
| ELiteral of k
and k = (* values *)
| KNil
| KList of k array
| KDictionary of d
| KFunction of f (* PERF?: fold [type f] into [type k], saves one unboxing step *)
| KInteger of int | KIntegerArray of int array
| KFloat of float | KFloatArray of float array
| KChar of char | KCharArray of char array (* PERF *)
| KSymbol of s | KSymbolArray of s array
| KSSymbol of string| KSSymbolArray of string array | KSDictionary of (string*k*k) array (* serialization-proof forms *)
and d = (* dictionaries *)
de H.t
and de = (* dictionary entries *)
{ value:k; attr:attr }
and attr = (* dictionary entry attributes *)
| ANil
| ADict of d
type c = (* command *)
| CEval of e (* (expr) *)
| CExit (* \\ *)
| CLoad of string (* \l *)
| CCd of h (* \d x *)
| CPwd (* \d *)
| CWsSave of string option (* \save *)
| CWsLoad of string option (* \load *)
| CWsSize (* \w *)
module Hk = Hashtbl.Make(struct type t = k let equal x y = x=y and hash = Hashtbl.hash end)
module Hf = Hashtbl.Make(struct type t = float let equal x y = x=y and hash = Hashtbl.hash end)
let is_atom = function | KInteger _ | KFloat _ | KSymbol _ | KChar _ | KNil | KFunction _ -> true | _ -> false
[@@inline always] let kinteger x = KInteger x
[@@inline always] let kfloat x = KFloat x
[@@inline always] let kchar x = KChar x
[@@inline always] let ksymbol x = KSymbol x
[@@inline always] let kintegerarray x = KIntegerArray x
[@@inline always] let kfloatarray x = KFloatArray x
[@@inline always] let kchararray x = KCharArray x
[@@inline always] let ksymbolarray x = KSymbolArray x
[@@inline always] let klist x = KList x
[@@inline always] let kdictionary x = KDictionary x
[@@inline always] let elambda x y = ELambda(x,y)
[@@inline always] let eapp x y = EApp(x,y)
[@@inline always] let eadverb x y = EAdverb(x,y)
[@@inline always] let eseq x y = ESeq(x,y)
[@@inline always] let eassign x y = EAssign(x,y)
[@@inline always] let eassignglobal x y = EAssignGlobal(x,y)
[@@inline always] let eassignmonad x y = EAssignMonad(x,y)
[@@inline always] let eassigndyad x y z = EAssignDyad(x,y,z)
[@@inline always] let eassignindex x y z = EAssignIndex(x,y,z)
[@@inline always] let eassignindexmonad x y z = EAssignIndexMonad(x,y,z)
[@@inline always] let eassignindexdyad x y z u = EAssignIndexDyad(x,y,z,u)
[@@inline always] let eifsimple x y z = EIfSimple(x,y,z)
[@@inline always] let eifmulti x y z = EIfMulti(x,y,z)
[@@inline always] let elist x = EList x
[@@inline always] let ereturn x = EReturn x
[@@inline always] let ename x = EName x
[@@inline always] let enamesys x = ENameSys x
[@@inline always] let everb x = EVerb x
[@@inline always] let ecomp x y = EComp(x,y)
[@@inline always] let everbmonadic x = EVerbMonadic x
[@@inline always] let eliteral x = ELiteral x
[@@inline always] let ea1 x = Ea1 x
[@@inline always] let ea2 x y = Ea2 (x,y)
[@@inline always] let ea3 x y z = Ea3 (x,y,z)
[@@inline always] let ea x = Ea x
let ceval x = CEval x
let cload x = CLoad x
let cwssave x = CWsSave x
let cwsload x = CWsLoad x
let ccd x = CCd x
let ensure_suffix s f = if Filename.check_suffix f s then f else f^s
exception Not_implemented_attribute
exception Not_implemented_format
exception Not_implemented_builtins
exception Not_implemented_io
exception Not_implemented_dynlink
exception Not_implemented_apply
exception Return of k
exception KReturn of k
exception KExit
exception KError_length
exception KError_index
exception KError_valence
exception KError_type
exception KError_domain
exception KError_rank
exception KError_limit
exception KError_nonce
exception KError_unmatched
let kinteger_prj = function KInteger x->x|_->raise KError_type
let kfloat_prj = function KFloat x->x|_->raise KError_type
and kchar_prj = function KChar x->x|_->raise KError_type
and ksymbol_prj = function KSymbol x->x|_->raise KError_type
and kdictionary_prj = function KDictionary x->x|_->raise KError_type
[@@inline always] let len = Array.length
[@@inline always] let id x = x
[@@inline always] let const x _ = x
let partial_app_dyad f ks is = KFunction (if len is = 0 then FDyad f else let x = ks.(0) in FMonad (if is.(0) = 0 then f x else (fun y -> f y x)))
let partial_app_triad f ks is = KFunction (match is with
| [|0;1|] -> let x=ks.(0) and y=ks.(1) in FMonad (f x y)
| [|0;2|] -> let x=ks.(0) and z=ks.(1) in FMonad (fun y -> f x y z)
| [|1;2|] -> let y=ks.(0) and z=ks.(1) in FMonad (fun x -> f x y z)
| [|0|] -> let x=ks.(0) in FDyad (fun y z -> f x y z)
| [|1|] -> let y=ks.(0) in FDyad (fun x z -> f x y z)
| [|2|] -> let z=ks.(0) in FDyad (fun x y -> f x y z)
| [||] -> FTriad f
| _ -> assert false)
let partial_app_tetrad f ks is = KFunction (match is with
| [|0;1;2|] -> let x=ks.(0) and y=ks.(1) and z=ks.(2) in FMonad (f x y z)
| [|0;1;3|] -> let x=ks.(0) and y=ks.(1) and u=ks.(2) in FMonad (fun z -> f x y z u)
| [|0;2;3|] -> let x=ks.(0) and z=ks.(1) and u=ks.(2) in FMonad (fun y -> f x y z u)
| [|1;2;3|] -> let y=ks.(0) and z=ks.(1) and u=ks.(2) in FMonad (fun x -> f x y z u)
| [|0;1|] -> let x=ks.(0) and y=ks.(1) in FDyad (fun z u -> f x y z u)
| [|0;2|] -> let x=ks.(0) and z=ks.(1) in FDyad (fun y u -> f x y z u)
| [|0;3|] -> let x=ks.(0) and u=ks.(1) in FDyad (fun y z -> f x y z u)
| [|1;2|] -> let y=ks.(0) and z=ks.(1) in FDyad (fun x u -> f x y z u)
| [|1;3|] -> let y=ks.(0) and u=ks.(1) in FDyad (fun x z -> f x y z u)
| [|2;3|] -> let z=ks.(0) and u=ks.(1) in FDyad (fun x y -> f x y z u)
| [|0|] -> let x=ks.(0) in FTriad (fun y z u -> f x y z u)
| [|1|] -> let y=ks.(0) in FTriad (fun x z u -> f x y z u)
| [|2|] -> let z=ks.(0) in FTriad (fun x y u -> f x y z u)
| [|3|] -> let u=ks.(0) in FTriad (fun x y z -> f x y z u)
| [||] -> FNary(4,function [|x;y;z;u|] -> f x y z u|_->assert false)
| _ -> assert false)
let partial_app_nary f n ks is js = KFunction (
let m = len is and a = Array.make n KNil in for i = 0 to m-1 do a.(is.(i)) <- ks.(i); done;
if m=0 then FNary(n,f) else match n-m with
| 1 -> FMonad (fun x -> a.(js.(0)) <- x; f a)
| 2 -> FDyad (fun x y -> a.(js.(0)) <- x; a.(js.(1)) <- y; f a)
| 3 -> FTriad (fun x y z -> a.(js.(0)) <- x; a.(js.(1)) <- y; a.(js.(2)) <- z; f a)
| p -> FNary(p,fun a' -> for i = 0 to p-1 do a.(js.(i)) <- a'.(i); done; f a))
let partial_app_nary_prefix f n m xs = KFunction (
let a = Array.make n KNil in for i=0 to m-1 do a.(i) <- xs.(i); done;
if m=0 then FNary(n,f) else match n-m with
| 1 -> FMonad(fun x -> a.(n-1)<-x;f a)
| 2 -> FDyad(fun x y -> a.(n-2)<-x;a.(n-1)<-y;f a)
| 3 -> FTriad(fun x y z -> a.(n-3)<-x;a.(n-2)<-y;a.(n-1)<-z;f a)
| p -> FNary(p,fun a' -> for i=0 to p-1; do a.(m+i) <- a'.(i); done;f a))
(* config ================================================================== *)
type config = {
mutable compare_tolerance : float; (* runtime (mutable) *)
mutable approx_tolerance : float;
mutable hash_size : int;
mutable workspace_name : string;
local_env_hash_size : int; (* static *)
approx_iter : int;
}
let config = {
compare_tolerance = epsilon_float;
approx_tolerance = 1e-6;
hash_size = 128;
workspace_name = "ok_workspace";
local_env_hash_size = 5;
approx_iter = 20;
}
(* symbol table ============================================================ *)
module St = Hashtbl.Make(struct type t = string let equal x y = x=y and hash x = Hashtbl.hash x end)
let _S : s St.t = St.create config.hash_size (* string -> symbol *)
let _Srev : string H.t = H.create config.hash_size (* symbol -> string *)
let _Sh : h H.t = H.create config.hash_size (* symbol -> handle *)
let _Smax = ref (-1)
let s x h = if St.mem _S x then St.find _S x else (
incr _Smax; let s = !_Smax in St.add _S x s; H.replace _Srev s x;
(match h with None -> H.replace _Sh s (HRel [s]) | Some h -> H.replace _Sh s h);s)
let sname = H.find _Srev
let handle = H.find _Sh
let handle_abs s = match handle s with HAbs h -> h | _ -> raise Not_found
(* built-ins *)
let s0 = s "" (Some (HAbs [])) and s0r = s "" (Some (HRel [])) and sx = s "x" None and sy = s "y" None and sz = s "z" None
and s_in = s "_in" None and s_lin = s "_lin" None and s_n = s "_n" None and s_d = s "_d" None and s_log = s "_log" None
and s_exp = s "_exp" None and s_sin = s "_sin" None and s_sinh = s "_sinh" None and s_cos = s "_cos" None and s_cosh = s "_cosh" None
and s_tan = s "_tan" None and s_tanh = s "_tanh" None and s_sqrt = s "_sqrt" None and s_sqr = s "_sqr" None and s_ic = s "_ic" None
and s_ci = s "_ci" None and s_mul = s "_mul" None and s_dot = s "_dot" None and s_pretty = s "_pretty" None
(* dict utils ============================================================== *)
let dmake n = H.create n
let dget_exn d s = H.find d s
let dgetv_or_nil d s = try (dget_exn d s).value with Not_found -> KNil
let dget d s = if H.mem d s then Some (dget_exn d s) else None
let dset d s v = H.replace d s v
let dsetv d s value = let attr = if H.mem d s then (H.find d s).attr else ANil in dset d s {value;attr}
let dmapv_inplace d f = H.iter (fun k {value;attr} -> dset d k {value=f value;attr}) d
let dcopy = H.copy
let rec dsetl d ss v = match ss with
| [] -> raise KError_domain
| [s] -> dset d s v
| s::ss -> (match dget d s with
| Some {value=KDictionary d;_} -> dsetl d ss v
| None ->
let d' = dmake config.hash_size in
dset d s {value=KDictionary d';attr=ANil};
dsetl d' ss v
| _ -> raise KError_type)
let rec dgetl_exn d ss = match ss with
| [] -> KDictionary d
| [s] -> (dget_exn d s).value
| s::ss -> (match dget_exn d s with {value=KDictionary d;_} -> dgetl_exn d ss |_ -> raise KError_type)
let dmakel xs =
let n = len xs in let d = dmake n in
Array.iter (function
| KList [|KSymbol s;value;KNil|]
| KList [|KSymbol s;value|] -> dset d s {value;attr=ANil}
| KList [|KSymbol s;value;KDictionary attr|] -> dset d s {value;attr=ADict attr}
| KList _ -> raise KError_type
| _ -> raise KError_rank) xs;
d
let dkeys d =
let n = H.length d in
let a = Array.make n s0 in
let i = ref 0 in H.iter (fun k _ -> a.(!i)<-k;incr i) d;
a
let dvalues d =
let n = H.length d in
let a = Array.make n KNil in
let i = ref 0 in H.iter (fun k v -> a.(!i) <- KList [|KSymbol k;v.value;match v.attr with ANil->KNil|ADict d->KDictionary d|];incr i) d;
a
(* k-tree ================================================================== *)
let ktree : d ref = ref(dmake config.hash_size)
let ktree_pwd : d ref = ref (dmake config.hash_size)
let s_k = s "k" None let _ = dsetv (!ktree) s_k (KDictionary(!ktree_pwd))
let ktree_env : d list ref = ref [!ktree_pwd]
let ktree_pwdh : s list ref = ref [s_k]
let ktree_set_pwdh h = ktree_pwdh:=(match h with HRel h -> !ktree_pwdh@h | HAbs h -> h)
[@@inline always] let ktree_cd d = ktree_env:=(match !ktree_env with h::t -> d::t|[]->[d])
[@@inline always] let ktree_in d f = let p= !ktree_env in ktree_env:=d; let k = try f() with e -> (ktree_env:=p; raise e) in ktree_env:=p;k
let kgetl_abs_exn h = dgetl_exn !ktree h
let kgetl_rel_exn h =
let rec loop = function
[] -> kgetl_abs_exn h | d::ds -> (try dgetl_exn d h with Not_found -> loop ds)
in loop !ktree_env
let kgeth_exn = function HAbs h -> kgetl_abs_exn h | HRel h -> kgetl_rel_exn h
let kgeth_or_nil h = try kgeth_exn h with Not_found -> KNil
let kgets_exn s = match handle s with HAbs h -> kgetl_abs_exn h | HRel h -> dgetl_exn !ktree_pwd h
let ksetl_abs h = dsetl !ktree h
let ksetl_rel h v = dsetl (List.hd !ktree_env) h v
let kseth h v = match h with HAbs h -> ksetl_abs h v | HRel h -> ksetl_rel h v
let ksethv h value = kseth h {value;attr=ANil}
let ksethv_ret h v = ksethv h v; v
let ksets s v = match handle s with HAbs h -> ksetl_abs h v | HRel h -> dsetl !ktree_pwd h v
let ksetsv s value = ksets s {value;attr=ANil}
let ksetsv_ret s v = ksetsv s v; v
(* pretty-printing (ugly code) ============================================= *)
let fpf = Format.fprintf
let fps : (Format.formatter -> unit) -> bytes =
let buffer = Buffer.create 80 in
let formatter = Format.formatter_of_buffer buffer in
(fun f ->
f formatter; Format.pp_print_flush formatter ();
let bytes = Buffer.to_bytes buffer in Buffer.clear buffer;
bytes)
let pp_sep f ~sep g a =
let n = len a in if n > 0 then for i = 0 to n-1 do
g f a.(i); if i < n-1 then fpf f sep;
done
let aall p xs =
let n = len xs in
try for i = 0 to n-1 do if not (p xs.(i)) then raise (Return KNil) done; true
with Return _ -> false
let is_lowercase t = 'a'<=t&&t<='z' and is_uppercase t = 'A'<=t&&t<='Z' and is_digit t = '0'<=t&&t<='9'
let is_alpha t = is_lowercase t || is_uppercase t let is_alphanum t = is_alpha t || is_digit t
let sn_escape s = let n = String.length s in try (for i=0 to n-1 do if not (is_alphanum s.[i]||s.[i]='_'||s.[i]='.') then raise Exit;done;s) with Exit -> "\""^s^"\""
let pp_s f s = fpf f "@[`%s@]" (sn_escape (sname s))
let pp_sn f s = fpf f "@[%s@]" (sn_escape (sname s))
let pp_a f g a = fpf f "@[%a@]" (fun f -> pp_sep f ~sep:" " g) a
let pp_ca f a = fpf f "@[\""; Array.iter (fun c -> fpf f "%s" (Char.escaped c)) a; fpf f "\"@]"
let rec pp_k f = function
| KNil -> ()
| KList [|k|] -> fpf f "@[,%a@]" pp_k k
| KList ks -> if aall is_atom ks then fpf f "@[(%a)@]" (fun f -> pp_sep f ~sep:";" pp_k) ks
else fpf f "@[(%a)@]" (fun f -> pp_sep f ~sep:"@\n " pp_k) ks
| KDictionary d -> fpf f "@[.%a@]" pp_k (KList(dvalues d))
| KFunction (FNilad _) -> fpf f "(fun/0)"
| KFunction (FMonad _) -> fpf f "(fun/1)"
| KFunction (FMonadDyad _) -> fpf f "(fun/1,2)"
| KFunction (FMonadDyadTriad _) -> fpf f "(fun/1,2,3)"
| KFunction (FMonadDyadTriadTetrad _) -> fpf f "(fun/1,2,3,4)"
| KFunction (FDyad _) -> fpf f "(fun/2)"
| KFunction (FTriad _) -> fpf f "(fun/3)"
| KFunction (FNary (n,_)) -> fpf f "(fun/%d)" n
| KInteger i -> fpf f "%d" i
| KIntegerArray [||] -> fpf f "!0"
| KIntegerArray [|i|] -> fpf f ",%d" i
| KIntegerArray a -> pp_a f (fun f -> fpf f "%d") a
| KFloat x -> Format.pp_print_float f x
| KFloatArray [|x|] -> fpf f ",%a" Format.pp_print_float x
| KFloatArray a -> pp_a f Format.pp_print_float a
| KChar c -> fpf f "\"%s\"" (Char.escaped c)
| KCharArray a -> pp_ca f a
| KSymbol s -> pp_s f s
| KSymbolArray [||] -> fpf f "0#`"
| KSymbolArray [|s|] -> fpf f ","; pp_s f s
| KSymbolArray a -> pp_a f pp_s a
and pp_de f = function
| KList [|k;v|] -> fpf f "@[(%a;%a)@]" pp_k k pp_k v
| KList [|k;v;a|] -> fpf f "@[(%a;%a;%a)@]" pp_k k pp_k v pp_k a
| _ -> assert false
let rec pp_h f = function
| HRel ss -> pp_sep f ~sep:"." pp_sn (Array.of_list ss)
| HAbs ss -> fpf f "."; pp_sep f ~sep:"." pp_sn (Array.of_list ss)
let rec pp_e f = function
| ELambda (args, e) -> fpf f "@[{[%a] %a}@]" (fun f -> pp_sep f ~sep:";" pp_sn) args pp_e e
| EApp (e,ea) ->
let args = match ea with
| Ea0 -> [||] | Ea1 x -> [|x|] | Ea2 (x,y) -> [|x;y|] | Ea3 (x,y,z) -> [|x;y;z|] | Ea args -> args in
fpf f "@["; pp_e f e; fpf f "["; pp_sep f ~sep:";" pp_e args; fpf f "]@]"
| EList es -> fpf f "@[(%a)@]" (fun f -> pp_sep f ~sep:";" pp_e) (Array.of_list es)
| EAdverb (av,e) ->
let av = match av with AVForwardslash -> "/" | AVForwardslashColon -> "/:" | AVBackslash -> "\\" | AVBackslashColon -> "\\:" | AVQuote -> "\'" | AVQuoteColon -> "\':"
in fpf f "@["; pp_e f e; fpf f "%s@]" av
| EReturn e -> fpf f "@[:%a@]" pp_e e
| ESeq (e,e') -> fpf f "@[%a;%a@]" pp_e e pp_e e'
| EIfSimple (i,t,e) -> fpf f "@[:[%a;%a;%a]@]" pp_e i pp_e t pp_e e
| EIfMulti (i,t,e) -> fpf f "@[if_multi@]"
| EAssign (h,e) -> fpf f "@[%a: %a@]" pp_h h pp_e e
| EAssignMonad (h,e) -> fpf f "@[%a %a:@]" pp_h h pp_e e
| EAssignDyad (h,e,e') -> fpf f "@[%a %a: %a@]" pp_h h pp_e e pp_e e'
| EAssignIndex (h,es,e) -> fpf f "@[%a[%a]: %a@]" pp_h h (fun f -> pp_sep f ~sep:";" pp_e) es pp_e e
| EAssignIndexMonad (h,es,e) -> fpf f "@[%a[%a] %a:@]" pp_h h (fun f -> pp_sep f ~sep:";" pp_e) es pp_e e
| EAssignIndexDyad (h,es,e,e') -> fpf f "@[%a[%a] %a: %a@]" pp_h h (fun f -> pp_sep f ~sep:";" pp_e) es pp_e e pp_e e'
| EAssignGlobal (h,e) -> fpf f "@[%a:: %a@]" pp_h h pp_e e
| EComp(e,e') -> fpf f "@[%a %a@]" pp_e e pp_e e'
| EName (HAbs []) -> fpf f "@[.`@]"
| EName h -> fpf f "@["; pp_h f h; fpf f "@]";
| ENameSys s -> fpf f "@[%s@]" (sname s);
| EVerbMonadic v -> fpf f "@["; pp_e f (EVerb v); fpf f ":"; fpf f "@]"
| EVerb v ->
let v = match v with
|VPlus->"+"|VMinus->"-"|VStar->"*"|VExclaim->"!"|VPercent->"%"|VPipe->"|"|VAmpersand->"&"
|VCircumflex->"^"|VLangle->"<"|VRangle->">"|VEquals->"="|VPound->"#"|VLodash->"_"|VTilde->"~"
|VDollar->"$"|VQuestion->"?"|VAt->"@"|VDot->"."|VComma->","|VZeroColon->"0:"|VOneColon->"1:"|VTwoColon->"2:"|VThreeColon->"3:"|VFourColon->"4:"|VFiveColon->"5:"
in fpf f "@[%s@]" v
| ELiteral k -> pp_k f k
| EColon -> fpf f "@[:@]"
| ENil -> ()
let pp_c f = function
| CEval e -> pp_e f e
| CExit -> fpf f "@[\\\\@]"
| CCd h -> fpf f "@[\\d %a@]" pp_h h
| CPwd -> fpf f "@[\\d@]"
| CLoad fn -> fpf f "@[\\l \"%s\"@]" (String.escaped fn)
| CWsLoad (Some fn) -> fpf f "@[\\load \"%s\"@]" (String.escaped fn)
| CWsLoad None -> fpf f "@[\\load@]"
| CWsSave (Some fn) -> fpf f "@[\\save \"%s\"@]" (String.escaped fn)
| CWsSave None -> fpf f "@[\\save@]"
| CWsSize -> fpf f "@[\\w@]"
let pp_cs f cs = List.iter (pp_c f) cs
(* stdlib / utilities ====================================================== *)
[@@inline always] let some x = Some x
let int_of_string s = try int_of_string s with Failure _ -> raise KError_domain
let float_of_string s = try float_of_string s with Failure _ -> raise KError_domain
let is_empty = function [] -> true | _ -> false
let swap t i j =
let tmp = t.(i) in
t.(i) <- t.(j);
t.(j) <- tmp
let arev_inplace t =
let i = ref 0 in
let j = ref (len t - 1) in
while !i < !j; do
swap t !i !j; incr i; decr j;
done
let array_of_list_rev xs = let a = Array.of_list xs in arev_inplace a; a
(* R. Sedgewick, "Analysis of shellsort and related algorithms", http://www.cs.princeton.edu/~rs/talks/shellsort.pdf *)
let shell_grade_inc = [|1073790977;268460033;67121153;16783361;4197377;1050113;262913;65921;16577;4193;1073;281;77;23;8;1;0|]
let shell_grade_inc_n = len shell_grade_inc
let shell_grade less x = (* PERF:avoid indexing through p (sort x itself simultaneously) *)
let n = len x in let p = Array.init n (fun i -> i) in
let i = ref 0 and j = ref 0 and h = ref 0 and t = ref 0 in
while shell_grade_inc.(!t) > n do incr t; done;
while !t < shell_grade_inc_n do
h := shell_grade_inc.(!t); i := !h;
while !i < n do
let vp = p.(!i) in j := !i;
while !j >= !h && less x.(vp) x.(p.(!j - !h)) do
p.(!j) <- p.(!j - !h); j := !j - !h;
done;
p.(!j) <- vp; incr i;
done; incr t;
done; p
let radix_grade_int_asc x = (* PERF:avoid indexing through p (sort x itself simultaneously) *)
let n = len x in
let c = Array.make 0x100 0 and b = Array.make 0x100 0
and p = Array.init n (fun i -> i) and aux = Array.make n 0
and j = ref 0 in
let pass p aux shift =
for i = 0 to n-1 do
let h = (x.(p.(i)) lsr shift) land 0xFF
in c.(h) <- 1+c.(h);
done;
j := 0; for i = 0 to 0xFF do
b.(i) <- !j; j := !j + c.(i); c.(i) <- 0;
done;
for i = 0 to n-1 do
let pi = p.(i) in let h = (x.(pi) lsr shift) land 0xFF in
let bh = b.(h) in aux.(bh) <- pi; b.(h) <- b.(h)+1;
done in
let sign p aux =
let nn = ref 0 in for i = 0 to n-1 do if x.(p.(i)) < 0 then incr nn; done;
j := 0; for i = 0 to n-1 do
let pi = p.(i) in
if x.(pi) >= 0 then (aux.(!nn) <- pi; incr nn) else (aux.(!j) <- pi; incr j)
done in
pass p aux 0; pass aux p 8; pass p aux 16;
sign aux p; p
let radix_grade_int_desc x = let x = radix_grade_int_asc x in arev_inplace x; x (* PERF/MEM *)
[@@inline always] let some x = Some x
[@@inline always] let flip f x y = f y x
[@@inline always] let comp f g x = f (g x)
[@@inline always] let comp3 f g h x = f (g (h x))
[@@inline always] let comp4 f g h i x = f (g (h (i x)))
[@@inline always] let comp_r f g x y = f x (g y)
[@@inline always] let comp_l f g x y = f (g x) y
[@@inline always] let comp_lr f g h x y = f (g x) (h y)
[@@inline always] let append x y = Array.append x y
[@@inline always] let aiter x f = let n = len x in for i = 0 to n-1 do f x.(i); done
[@@inline always] let aiteri x f = let n = len x in for i = 0 to n-1 do f x.(i) i; done
[@@inline always] let amap x f = Array.map f x
[@@inline always] let aget a i = try a.(i) with _ -> raise KError_index
let afindi xs x = let n = len xs in
let rec loop i = if i >= n then n else
if xs.(i) = x then i else loop (i+1)
in loop 0
let mod_pos x y = if x < 0 then y+(x mod y) else x mod y
let atake x y = let n = len y in (Array.init (abs x) (if x > 0 then fun i -> y.(mod_pos i n) else fun i -> y.(mod_pos (n+x+i) n)))
[@@inline always] let afoldl x ~f ~init = Array.fold_left f init x
let ascanl_map x ~f ~g ~init = let n = len x in
if n = 0 then []
else (let r = ref init in let a = ref [!r] in for i = 0 to n - 1 do r := f !r (g x.(i));a:=!r::!a; done; !a)
let ascanl1_map x ~f ~g = let n = len x in
if n = 0 then []
else (let r = ref (g x.(0)) in let a = ref [!r] in for i = 1 to n - 1 do r := f !r (g x.(i));a:=!r::!a; done; !a)
let areduce t ~f = let n = len t in
if n = 0 then raise KError_length
else (let r = ref t.(0) in for i = 1 to n - 1 do r := f !r t.(i) done; !r)
let areduce_map t ~f ~g = let n = len t in
if n = 0 then raise KError_length
else (let r = ref (g t.(0)) in for i = 1 to n - 1 do r := f !r (g t.(i)) done;!r)
[@@inline always] let azip_map f (x:'a array) (y:'b array) =
let n = len x in if n <> len y then raise KError_length
else Array.init n (fun i -> f x.(i) y.(i))
let azip_map_r g f = azip_map (comp_r f g)
let azip_map_l g f = azip_map (comp_l f g)
let azip_map_lr g h f = azip_map (comp_lr f g h)
[@@inline always] let aiter2 f (x:'a array) (y:'b array) =
let n = len x in if n <> len y then raise KError_length
else for i = 0 to n-1 do f x.(i) y.(i); done
[@@inline always] let aiteri2 f (x:'a array) (y:'b array) =
let n = len x in if n <> len y then raise KError_length
else for i = 0 to n-1 do f x.(i) y.(i) i; done
[@@inline always] let aiter2_ x y n f = for i = 0 to n-1 do f x.(i) y.(i); done
let aiter2_map_r g f = aiter2 (comp_r f g)
let aiter2_map_l g f = aiter2 (comp_l f g)
let aiter2_map_lr g h f = aiter2 (comp_lr f g h)
let amap_pairs f a = Array.init (len a-1) (fun i -> f a.(i) a.(i+1))
[@@inline always] let group xs ~hmake ~hmem ~hadd ~hiter ~hall =
let n = len xs in let h = hmake n and h1 = hmake n and j = ref 0 in
for i = 0 to n-1 do
let xsi = xs.(i) in
if not (hmem h xsi) then (hadd h xsi !j; incr j);
hadd h1 xsi i;
done;
let r = Array.make !j KNil in
hiter (fun x j -> r.(j) <- KIntegerArray (array_of_list_rev (hall h1 x))) h;
r
let group_k = group ~hmake:(fun _ -> Hk.create config.hash_size) ~hmem:Hk.mem ~hadd:Hk.add ~hiter:Hk.iter ~hall:Hk.find_all
let group_int = group ~hmake:(fun _ -> H.create config.hash_size) ~hmem:H.mem ~hadd:H.add ~hiter:H.iter ~hall:H.find_all
let group_float = group ~hmake:(fun _ -> Hf.create config.hash_size) ~hmem:Hf.mem ~hadd:Hf.add ~hiter:Hf.iter ~hall:Hf.find_all
let group_sym = group_int
let group_char x = group
~hmake:(fun _ -> Array.make 255 [])
~hmem:(fun h x -> not (is_empty h.(x)))
~hadd:(fun h x j -> h.(x) <- j :: h.(x))
~hall:(Array.get)
~hiter:(fun f h -> for i = 0 to 254 do if not (is_empty h.(i)) then f i (List.hd h.(i)); done) (Array.map Char.code x)
[@@inline always] let range ~hmake ~hmem ~hadd ~hiter ~nil xs =
let n = len xs in let h = hmake () and j = ref 0 in
for i = 0 to n-1 do
let xsi = xs.(i) in if not (hmem h xsi) then (hadd h xsi !j; incr j);
done;
let r = Array.make !j nil in
hiter (fun x j -> r.(j) <- x) h; r
let range_k = range ~hmake:(fun _ -> Hk.create 255) ~hmem:Hk.mem ~hadd:Hk.add ~hiter:Hk.iter ~nil:KNil
let range_int = range ~hmake:(fun _ -> H.create 255) ~hmem:H.mem ~hadd:H.replace ~hiter:H.iter ~nil:0
let range_float = range ~hmake:(fun _ -> Hf.create 255) ~hmem:Hf.mem ~hadd:Hf.add ~hiter:Hf.iter ~nil:0.0
let range_sym = range_int
let range_char x = range
~hmake:(fun _ -> Array.make 256 (-1))
~hmem:(fun h x -> h.(x) >= 0)
~hadd:(fun h x j -> h.(x) <- j)
~hiter:(fun f h -> for i = 0 to 255 do if h.(i) >= 0 then f (Char.chr i) h.(i); done)
~nil:' ' (Array.map Char.code x)
let klen = function
| KIntegerArray y -> len y | KFloatArray y -> len y | KCharArray y -> len y | KSymbolArray y -> len y | KList y -> len y
| _ -> 1
let kmap1 f = function
| KIntegerArray x -> amap x (comp f kinteger)
| KFloatArray x -> amap x (comp f kfloat)
| KCharArray x -> amap x (comp f kchar)
| KSymbolArray x -> amap x (comp f ksymbol)
| KList x -> amap x f
| _ -> raise KError_type
let rec kcopy_deep_box d = match d with (* PERF *)
| KDictionary d -> KDictionary (dcopy_deep_box d)
| KIntegerArray x -> KList (amap x kinteger)
| KFloatArray x -> KList (amap x kfloat)
| KCharArray x -> KList (amap x kchar)
| KSymbolArray x -> KList (amap x ksymbol)
| KList x -> KList (amap x kcopy_deep_box)
| KNil | KFunction _ | KInteger _ | KFloat _ | KChar _ | KSymbol _ -> d
and dcopy_deep_box d = let d = dcopy d in
H.iter (fun k {value;attr} -> dset d k {
value = kcopy_deep_box value;
attr = match attr with ANil -> attr | ADict d -> ADict (dcopy_deep_box d)}) d;
d
let blit ~src ~src_pos ~dst ~dst_pos ~len = Array.blit src src_pos dst dst_pos len
let arot (x:int) (y:'a array) : 'a array = (* PERF:blit *)
let len = len y in
let a = Array.copy y in
let x = x mod len in
let x = if x < 0 then len+x else x in
let k = len - x in
blit ~src:y ~src_pos:x ~dst:a ~dst_pos:0 ~len:k; (*SLOW*)
blit ~src:y ~src_pos:0 ~dst:a ~dst_pos:k ~len:x; (*SLOW*)
a
let krot x = function
| KIntegerArray y -> KIntegerArray (arot x y)
| KFloatArray y -> KFloatArray (arot x y)
| KCharArray y -> KCharArray (arot x y)
| KSymbolArray y -> KSymbolArray (arot x y)
| KList y -> KList (arot x y)
| _ -> raise KError_type
let as_list = function
| KIntegerArray x -> amap x kinteger
| KFloatArray x -> amap x kfloat
| KCharArray x -> amap x kchar
| KSymbolArray x -> amap x ksymbol
| KList x -> x
| x -> [|x|]
let sub a pos len = Array.sub a pos len
let explode s = Array.init (Bytes.length s) (fun i -> s.[i])
let adrop x y = let n = len y in let p,l = if x >= 0 then x,n-x else 0,n+x in sub y p l
let acut x y f = let n = len y in
let p, a = afoldl x ~init:(0,[]) ~f:(fun (p,xs) x -> if x-p>0 then (x,f (sub y p (x-p))::xs) else (x,xs)) in
if p < n then array_of_list_rev ((f (sub y p (n-p))) :: a) else array_of_list_rev a
let rec shape x = match x with
| KFunction _ | KDictionary _ | KInteger _ | KChar _ | KFloat _ | KSymbol _ | KNil -> [||]
| KCharArray _| KFloatArray _| KIntegerArray _| KSymbolArray _ -> [|klen x|]
| KList [||] -> [|0|]
| KList x ->
let n = len x in
let s = Array.init n (fun i -> shape x.(i)) in
let m = areduce_map ~f:min ~g:len s in
let acc = ref [] in
(try for j = 0 to m-1 do
let current = s.(0).(j) in
for i = 1 to n-1 do if s.(i).(j) <> current then raise Exit; done;
acc := current::!acc
done with Exit -> ());
Array.of_list (n::List.rev !acc)
let kvec xs =
let int = ref 0 and char = ref 0 and float = ref 0 and symbol = ref 0 in
try let n = len xs in if n = 0 then raise Exit else for i = 0 to n-1 do
(match xs.(i) with KInteger _ -> int:=1 | KFloat _ -> float:=1 | KChar _ -> char:=1 | KSymbol _ -> symbol:=1 |_-> raise Exit);
if !int+ !float+ !char+ !symbol > 1 then raise Exit;
done;
if !int>0 then KIntegerArray (amap xs kinteger_prj)
else if !char>0 then KCharArray (amap xs kchar_prj)
else if !float>0 then KFloatArray (amap xs kfloat_prj)
else if !symbol>0 then KSymbolArray (amap xs ksymbol_prj)
else assert false
with Exit -> KList xs
let rec kvec_deep = function KList d -> (match kvec d with KList d -> KList (amap d kvec_deep) |d -> d) | KDictionary d -> KDictionary(dmapv_inplace d kvec_deep;d) | d -> d
let kzip_with f x y = match x,y with
| KList x,KIntegerArray y -> azip_map_r kinteger f x y
| KList x,KFloatArray y -> azip_map_r kfloat f x y
| KList x,KCharArray y -> azip_map_r kchar f x y
| KList x,KSymbolArray y -> azip_map_r ksymbol f x y
| KList x,KList y -> azip_map f x y
| KList x,atom -> amap x (flip f atom)
| KIntegerArray x,KIntegerArray y -> azip_map_lr kinteger kinteger f x y
| KIntegerArray x,KFloatArray y -> azip_map_lr kinteger kfloat f x y
| KIntegerArray x,KCharArray y -> azip_map_lr kinteger kchar f x y
| KIntegerArray x,KSymbolArray y -> azip_map_lr kinteger ksymbol f x y
| KIntegerArray x,KList y -> azip_map_l kinteger f x y
| KIntegerArray x,atom -> amap x (comp (flip f atom) kinteger)
| KFloatArray x,KIntegerArray y -> azip_map_lr kfloat kinteger f x y
| KFloatArray x,KFloatArray y -> azip_map_lr kfloat kfloat f x y
| KFloatArray x,KCharArray y -> azip_map_lr kfloat kchar f x y
| KFloatArray x,KSymbolArray y -> azip_map_lr kfloat ksymbol f x y
| KFloatArray x,KList y -> azip_map_l kfloat f x y
| KFloatArray x,atom -> amap x (comp (flip f atom) kfloat)
| KCharArray x,KIntegerArray y -> azip_map_lr kchar kinteger f x y
| KCharArray x,KFloatArray y -> azip_map_lr kchar kfloat f x y
| KCharArray x,KCharArray y -> azip_map_lr kchar kchar f x y
| KCharArray x,KSymbolArray y -> azip_map_lr kchar ksymbol f x y
| KCharArray x,KList y -> azip_map_l kchar f x y
| KCharArray x,atom -> amap x (comp (flip f atom) kchar)
| KSymbolArray x,KIntegerArray y -> azip_map_lr ksymbol kinteger f x y
| KSymbolArray x,KFloatArray y -> azip_map_lr ksymbol kfloat f x y
| KSymbolArray x,KCharArray y -> azip_map_lr ksymbol kchar f x y
| KSymbolArray x,KSymbolArray y -> azip_map_lr ksymbol ksymbol f x y
| KSymbolArray x,KList y -> azip_map_l ksymbol f x y
| KSymbolArray x,atom -> amap x (comp (flip f atom) ksymbol)
| atom,KList x -> amap x (f atom)
| atom,KSymbolArray x -> amap x (comp (f atom) ksymbol)
| atom,KCharArray x -> amap x (comp (f atom) kchar)
| atom,KFloatArray x -> amap x (comp (f atom) kfloat)
| atom,KIntegerArray x -> amap x (comp (f atom) kinteger)
| _ -> raise KError_type
let kiter2_with f x y = match x,y with
| KList x,KIntegerArray y -> aiter2_map_r kinteger f x y
| KList x,KFloatArray y -> aiter2_map_r kfloat f x y
| KList x,KCharArray y -> aiter2_map_r kchar f x y
| KList x,KSymbolArray y -> aiter2_map_r ksymbol f x y
| KList x,KList y -> aiter2 f x y
| KList x,atom -> aiter x (flip f atom)
| KIntegerArray x,KIntegerArray y -> aiter2_map_lr kinteger kinteger f x y
| KIntegerArray x,KFloatArray y -> aiter2_map_lr kinteger kfloat f x y
| KIntegerArray x,KCharArray y -> aiter2_map_lr kinteger kchar f x y
| KIntegerArray x,KSymbolArray y -> aiter2_map_lr kinteger ksymbol f x y
| KIntegerArray x,KList y -> aiter2_map_l kinteger f x y
| KIntegerArray x,atom -> aiter x (comp (flip f atom) kinteger)
| KFloatArray x,KIntegerArray y -> aiter2_map_lr kfloat kinteger f x y
| KFloatArray x,KFloatArray y -> aiter2_map_lr kfloat kfloat f x y
| KFloatArray x,KCharArray y -> aiter2_map_lr kfloat kchar f x y
| KFloatArray x,KSymbolArray y -> aiter2_map_lr kfloat ksymbol f x y
| KFloatArray x,KList y -> aiter2_map_l kfloat f x y
| KFloatArray x,atom -> aiter x (comp (flip f atom) kfloat)
| KCharArray x,KIntegerArray y -> aiter2_map_lr kchar kinteger f x y
| KCharArray x,KFloatArray y -> aiter2_map_lr kchar kfloat f x y
| KCharArray x,KCharArray y -> aiter2_map_lr kchar kchar f x y
| KCharArray x,KSymbolArray y -> aiter2_map_lr kchar ksymbol f x y
| KCharArray x,KList y -> aiter2_map_l kchar f x y
| KCharArray x,atom -> aiter x (comp (flip f atom) kchar)
| KSymbolArray x,KIntegerArray y -> aiter2_map_lr ksymbol kinteger f x y
| KSymbolArray x,KFloatArray y -> aiter2_map_lr ksymbol kfloat f x y
| KSymbolArray x,KCharArray y -> aiter2_map_lr ksymbol kchar f x y
| KSymbolArray x,KSymbolArray y -> aiter2_map_lr ksymbol ksymbol f x y
| KSymbolArray x,KList y -> aiter2_map_l ksymbol f x y
| KSymbolArray x,atom -> aiter x (comp (flip f atom) ksymbol)
| atom,KList x -> aiter x (f atom)
| atom,KSymbolArray x -> aiter x (comp (f atom) ksymbol)
| atom,KCharArray x -> aiter x (comp (f atom) kchar)
| atom,KFloatArray x -> aiter x (comp (f atom) kfloat)
| atom,KIntegerArray x -> aiter x (comp (f atom) kinteger)
| atom,atom' -> f atom atom'
let kiter_with f x = match x with
| KList x -> aiter x f
| KIntegerArray x -> aiter x (comp f kinteger)
| KFloatArray x -> aiter x (comp f kfloat)
| KCharArray x -> aiter x (comp f kchar)
| KSymbolArray x -> aiter x (comp f ksymbol)
| atom -> f atom
let kaiter_with f x a = match x with
| KList x -> aiter2 f x a
| KIntegerArray x -> aiter2 (comp f kinteger) x a
| KFloatArray x -> aiter2 (comp f kfloat) x a
| KCharArray x -> aiter2 (comp f kchar) x a
| KSymbolArray x -> aiter2 (comp f ksymbol) x a
| atom -> aiter a (fun a -> f atom a)
let kaiteri_with f x a = match x with
| KList x -> aiteri2 f x a
| KIntegerArray x -> aiteri2 (comp f kinteger) x a
| KFloatArray x -> aiteri2 (comp f kfloat) x a
| KCharArray x -> aiteri2 (comp f kchar) x a
| KSymbolArray x -> aiteri2 (comp f ksymbol) x a
| atom -> aiteri a (fun a i -> f atom a i)
let rec kmap_rec f = function KList x -> f (KList (amap x (kmap_rec f))) | x -> f x
let list_of_kap n ks is = let x = Array.make n KNil in aiter2 (fun k i -> x.(i) <- k) ks is; x
let k_of_kargs = function
| Ka0 -> KNil | Ka1 x -> x
| Ka2 (x,y) -> kvec [|x;y|] | Ka3 (x,y,z) -> kvec [|x;y;z|] | Ka xs -> kvec xs
| Kap (n,ks,is,js) -> KList (list_of_kap n ks is)
let klist_of_kargs = function
| Ka0 -> KNil | Ka1 x -> KList [|x|] | Ka2 (x,y) -> KList [|x;y|] | Ka3 (x,y,z) -> KList [|x;y;z|] | Ka x -> KList x
| Kap (n,ks,is,_) -> KList (list_of_kap n ks is)
let fmonad_prj = function (FMonadDyadTriadTetrad (f,_,_,_)|FMonadDyadTriad (f,_,_)|FMonadDyad (f,_)|FMonad f) -> f
| FNilad _ -> raise KError_valence
| FDyad f -> (fun x -> KFunction (FMonad (f x)))
| FTriad f -> (fun x -> KFunction (FDyad (f x)))
| FNary (n,f) -> (fun x -> partial_app_nary_prefix f n 1 [|x|])
let kfmonad_prj = function KFunction f -> fmonad_prj f | KNil -> id |_ -> raise KError_type
let fdyad_prj = function (FMonadDyadTriadTetrad (_,f,_,_)|FMonadDyadTriad (_,f,_)|FMonadDyad (_,f)|FDyad f) -> f
| FNilad _|FMonad _ -> raise KError_valence
| FTriad f -> (fun x y -> KFunction (FMonad (f x y)))
| FNary (n,f) -> (fun x y -> partial_app_nary_prefix f n 2 [|x;y|])
let kfdyad_prj = function KFunction f -> fdyad_prj f |KNil -> (fun x y -> kvec [|x;y|]) |_ -> raise KError_type
let ftriad_prj = function (FMonadDyadTriadTetrad (_,_,f,_)|FMonadDyadTriad (_,_,f)|FTriad f) -> f
| FNilad _|FMonad _|FDyad _|FMonadDyad _ -> raise KError_valence
| FNary (n,f) -> (fun x y z -> partial_app_nary_prefix f n 3 [|x;y;z|])
let kftriad_prj = function KFunction f -> ftriad_prj f |KNil -> (fun x y z -> kvec [|x;y;z|]) |_ -> raise KError_type
let ftetrad_prj = function FMonadDyadTriadTetrad (_,_,_,f) -> f
| FNary(n,f) when n>=4 -> (fun x y z u -> partial_app_nary_prefix f n 4 [|x;y;z;u|])
| _ -> raise KError_valence
let kftetrad_prj = function KFunction f -> ftetrad_prj f | KNil -> (fun x y z u -> kvec [|x;y;z;u|]) | _ -> raise KError_type
let secant_root ~f ~x0 ~x1 ~max_iter ~tolerance =
let rec loop xn1 fxn1 xn2 fxn2 i =
if i = max_iter then raise KError_limit;
let xn = xn1 -. (fxn1 *. ((xn1 -. xn2) /. (fxn1 -. fxn2))) in
let fxn = f xn in
if abs_float fxn < tolerance then xn
else loop xn fxn xn1 fxn1 (i+1)
in loop x1 (f x1) x0 (f x0) 0
(* symbol parser (already req'd for marshalling) =========================== *)
module Symbol_parser = struct open Tinyparse open Lexer
let t = token let tm = token_map let ws = t WS let tws tk = t tk |^> skip ws
let tname = tm (function NAME i -> i |_->fail())
let pnames = sep_token1 DOT tname |>> fun l -> (String.concat "." l, List.map (flip s None) l)
let phandle = choice [t DOT |>^ pnames |>> (fun (x,h) -> "."^x,HAbs h);pnames |>> (fun (x,h) -> x,HRel h)]
let parse_symbol s =
let rec tokenize b ts = match Lexer.read b with EOF-> array_of_list_rev (EOF::ts) |t->tokenize b (t::ts) in
let tokens = tokenize (Lexing.from_string s) [] in fst (phandle {tokens;pos=0})
end include Symbol_parser
(* adverbs ================================================================= *)
(* <adverb>_<arg-valence><result-valence> *)
let each_dd f x y = kvec (kzip_with f x y)
let each_left_dd f x y = match x,y with
| KList x, y -> kvec (amap x (fun x -> f x y))
| KSymbolArray x, y -> kvec (amap x (flip (comp_l f ksymbol) y))
| KIntegerArray x, y -> kvec (amap x (flip (comp_l f kinteger) y))
| KFloatArray x, y -> kvec (amap x (flip (comp_l f kfloat) y))
| KCharArray x, y -> kvec (amap x (flip (comp_l f kchar) y))
| x, y -> f x y
let each_right_dd f x y = match x,y with
| x, KList y -> kvec (amap y (f x))
| x, KSymbolArray y -> kvec (amap y (comp_r f ksymbol x))
| x, KIntegerArray y -> kvec (amap y (comp_r f kinteger x))
| x, KFloatArray y -> kvec (amap y (comp_r f kfloat x))
| x, KCharArray y -> kvec (amap y (comp_r f kchar x))
| _ -> raise KError_type
let over_dd f x y = match y with
| KList y -> afoldl ~init:x ~f y
| KSymbolArray y -> afoldl ~init:x ~f:(comp_r f ksymbol) y
| KIntegerArray y -> afoldl ~init:x ~f:(comp_r f kinteger) y
| KFloatArray y -> afoldl ~init:x ~f:(comp_r f kfloat) y
| KCharArray y -> afoldl ~init:x ~f:(comp_r f kchar) y
| _ -> f x y
let over_mm f x =
let ix = x in
let rec loop x =
let fx = f x in
if x = fx || ix = fx then fx else loop fx
in loop ix
let scan_mm (f:k -> k) x =
let ix = x in
let rec loop acc x =
let fx = f x in
let acc = fx::acc in
if x = fx || ix = fx then acc
else loop acc fx
in kvec (array_of_list_rev (loop [] ix))
let each_mm f x = match x with
| KList x -> kvec (amap x f)
| KSymbolArray x -> kvec (amap x (comp f ksymbol))
| KIntegerArray x -> kvec (amap x (comp f kinteger))
| KFloatArray x -> kvec (amap x (comp f kfloat))
| KCharArray x -> kvec (amap x (comp f kchar))
| x -> f x
let over_md f x y = match x,y with
| KInteger n, x when n >= 0 ->
let rec loop x = function 0 -> x | n -> loop (f x) (n-1)
in loop x n
| KInteger _, _ -> raise KError_domain
| KFunction (FMonad b | FMonadDyad (b,_) | FMonadDyadTriad (b,_,_) | FMonadDyadTriadTetrad (b,_,_,_)), x (* b f\ x *) ->
let b x = b x = KInteger 0 in
let rec loop x = if b x then x else loop (f x)
in loop x
| KFunction _, _ -> raise KError_valence
| _ -> raise KError_type
let scan_md f x y = match x,y with
| KInteger n, x when n >= 0 ->
let rec loop acc x = function 0 -> acc | n -> let fx = f x in loop (fx::acc) fx (n-1)
in kvec (array_of_list_rev (loop [] x n))
| KInteger _, _ -> raise KError_domain
| KFunction (FMonad b | FMonadDyad (b,_) | FMonadDyadTriad (b,_,_) | FMonadDyadTriadTetrad (b,_,_,_)), x (* b f/ x *) ->
let b x = b x = KInteger 0 in
let rec loop acc x = if b x then acc else let fx = f x in loop (fx::acc) fx
in kvec (array_of_list_rev (loop [] x))
| KFunction _, _ -> raise KError_valence
| _ -> raise KError_type
let each_pair_dm f x = match x with
| KSymbol _ | KInteger _ | KFloat _ | KChar _ ->
f x x
| KList [||] | KSymbolArray [||] | KIntegerArray [||] | KFloatArray [||] | KCharArray [||] ->
raise KError_length
| KList x -> kvec (amap_pairs f x)
| KSymbolArray x -> kvec (amap_pairs (comp_lr f ksymbol ksymbol) x)
| KIntegerArray x -> kvec (amap_pairs (comp_lr f kinteger kinteger) x)
| KFloatArray x -> kvec (amap_pairs (comp_lr f kfloat kfloat) x)
| KCharArray x -> kvec (amap_pairs (comp_lr f kchar kchar) x)
| _ -> raise KError_type
let over_dm f x = match x with
| KList x -> areduce ~f x
| KIntegerArray x -> areduce_map ~f ~g:kinteger x
| KFloatArray x -> areduce_map ~f ~g:kfloat x
| KSymbolArray x -> areduce_map ~f ~g:ksymbol x
| KCharArray x -> areduce_map ~f ~g:kchar x
| _ -> raise KError_type
let scan_dm f x = match x with
| KList x -> kvec (array_of_list_rev (ascanl1_map ~f ~g:(fun x ->x) x))
| KIntegerArray x -> kvec (array_of_list_rev (ascanl1_map ~f ~g:kinteger x))
| KFloatArray x -> kvec (array_of_list_rev (ascanl1_map ~f ~g:kfloat x))
| KSymbolArray x -> kvec (array_of_list_rev (ascanl1_map ~f ~g:ksymbol x))
| KCharArray x -> kvec (array_of_list_rev (ascanl1_map ~f ~g:kchar x))
| _ -> raise KError_type
let scan_dd f x y = match y with
| KList y -> kvec (array_of_list_rev (ascanl_map ~f ~g:(fun y ->y) ~init:x y))
| KIntegerArray y -> kvec (array_of_list_rev (ascanl_map ~f ~g:kinteger ~init:x y))
| KFloatArray y -> kvec (array_of_list_rev (ascanl_map ~f ~g:kfloat ~init:x y))
| KSymbolArray y -> kvec (array_of_list_rev (ascanl_map ~f ~g:ksymbol ~init:x y))
| KCharArray y -> kvec (array_of_list_rev (ascanl_map ~f ~g:kchar ~init:x y))
| _ -> raise KError_type
(* verb utils ============================================================== *)
let rec atomic_m (f:k -> k) (x:k) = if is_atom x then f x else kvec (kmap1 (atomic_m f) x)
let rec atomic_d f x y = match is_atom x,is_atom y with
| true,true -> f x y
| true,false -> kvec (kmap1 (fun y -> (atomic_d f) x y) y)
| false,true -> kvec (kmap1 (fun x -> (atomic_d f) x y) x)
| false,false -> kvec (kzip_with (atomic_d f) x y)
[@@inline always] let num_atomic_m ~f_int ~f_float = atomic_m (fun x ->
match x with
| KInteger x -> f_int x
| KFloat x -> f_float x
| _ -> raise KError_type)
[@@inline always] let num_atomic_d ~f_int ~f_float = atomic_d (fun x y -> match x,y with
| KInteger n, KInteger m -> KInteger (f_int n m)
| KFloat n, KFloat m -> KFloat (f_float n m)
| KInteger n, KFloat m -> KFloat (f_float (float_of_int n) m)
| KFloat n, KInteger m -> KFloat (f_float n (float_of_int m))
| x,y -> raise KError_type)
[@@inline always] let not_atomic_m ~f_int ~f_float ~f_sym ~f_char ~f_k = function
| KIntegerArray xs -> f_int xs
| KFloatArray xs -> f_float xs
| KSymbolArray xs -> f_sym xs
| KCharArray xs -> f_char xs
| KList xs -> f_k xs
| _ -> raise KError_rank
[@@inline always] let float_atomic_d f = atomic_d (fun x y -> match x,y with
| KInteger n, KInteger m -> KFloat (f (float_of_int n) (float_of_int m))
| KFloat n, KFloat m -> KFloat (f n m)
| KInteger n, KFloat m -> KFloat (f (float_of_int n) m)
| KFloat n, KInteger m -> KFloat (f n (float_of_int m))
| _ -> raise KError_type)
[@@inline always] let float_atomic_m f = num_atomic_m ~f_float:f ~f_int:(comp f float_of_int)
[@@inline always] let float_atomic_d2 f = atomic_d (fun x y -> match x,y with (* FIXME *)
| KInteger n, KInteger m -> f (float_of_int n) (float_of_int m)
| KFloat n, KFloat m -> f n m
| KInteger n, KFloat m -> f (float_of_int n) m
| KFloat n, KInteger m -> f n (float_of_int m)
| _ -> raise KError_type)
(* verbs =================================================================== *)
let vplus = num_atomic_d ~f_int:(+) ~f_float:(+.)
let vplus_m x = match x with (* flip PERF:track types *)
| KList [||] -> x
| KList [|_|] -> x
| KList xs ->
let m = len xs in
let n = afoldl ~init:(-1) ~f:(fun acc x ->
if acc = -1 then klen x else
if is_atom x then acc else
if acc <> klen x then raise KError_length else acc) xs in
let at = amap xs @@ fun x ->
if is_atom x then const x
else match x with
| KIntegerArray xs -> fun j -> KInteger xs.(j)
| KFloatArray xs -> fun j -> KFloat xs.(j)
| KSymbolArray xs -> fun j -> KSymbol xs.(j)
| KCharArray xs -> fun j -> KChar xs.(j)
| KList xs -> fun j -> xs.(j)
| _ -> raise KError_rank
in let a = Array.make_matrix n m KNil in
for i = 0 to m-1 do
let at = at.(i) in for j = 0 to n-1 do a.(j).(i) <- at j done
done; kvec (Array.map klist a)
| _ -> x
let vminus = num_atomic_d ~f_int:(-) ~f_float:(-.)
let vminus_m = num_atomic_m ~f_int:(fun x -> KInteger (0-x)) ~f_float:(fun x -> KFloat (0.0-.x))
let vstar = num_atomic_d ~f_int:( * ) ~f_float:( *. )
let vstar_m x =
if is_atom x then x else match x with
| KIntegerArray [||] -> KInteger 0
| KIntegerArray xs -> KInteger xs.(0)
| KFloatArray [||] -> KFloat 0.0