-
Notifications
You must be signed in to change notification settings - Fork 2
Expand file tree
/
Copy pathutils.clp
More file actions
executable file
·5780 lines (5168 loc) · 206 KB
/
utils.clp
File metadata and controls
executable file
·5780 lines (5168 loc) · 206 KB
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
;CLIPS util funcitons, copyright of Michael Bobak@computer.org
;to be incl in any work I do, but as per contract not owned by anyone in particular
;that is not to say that non-utility code is not fully owned by the people who pay me.
;-bits of this are collected code from other, but much is my own; I wouldn't mind getting
; others to use it; I lean copyleft as I've benefitted, but could go bsd/etc.
;-consider using parts of auxiliary-functions.clp/ut-h &others, incl new clp ont files.
;=I hope to keep the RDF2clipsObject code w/in this file soon(as soon as I get rid of the C needed)
;= also event-rules for timer events/etc
(deffunction remove-duplicates (?l) ?l)
(deffunction bag-get (?a ?b) ?a)
(deffunction bag-set (?a ?b ?c) ?a)
(deffunction bag-create (?a) ?a)
(deffunction bag-delete (?a) ?a)
(deffunction tlst-get (?n ?b) ?n)
(deffunction tlst-set (?a ?b) ?a)
(deffunction tlst-create (?a) ?a)
(deffunction tlst-delete (?a) ?a)
(defglobal ?*tlst* = FALSE)
(defglobal ?*jess* = FALSE)
;[Only collected are really the LIST methods and a sort fnc.]
;(deffunction e () (exit)) ;change for jess
(deffunction ex () (exit))
(deffunction lo () (exit))
;(deffunction lo () (date) (ex))
(deffunction lt () (load t.clp))
(deffunction lt2 () (load t2.clp))
(deffunction lt3 () (load t3.clp))
;(deffunction lt2 () (load fxm2.clp)) ;changes
;(deffunction lf () (load fixmsg.clp))
(deffunction map2 (?f ?a ?b $?args) (printout t crlf "redef"));redef below
(deffunction lf () (load fxm2.clp))
(deffunction lfc () (load fxc.clp))
(deffunction lb () (batch b.bat))
(deffunction lb2 () (batch b2.bat))
(deffunction lb0 () (batch b0.bat))
(deffunction lp () (load poc.clp))
(deffunction lbp () (lp) (lb))
(deffunction decrn (?n) (if (numberp ?n) then (- ?n 1) else 0))
;temp put this here:
(defglobal ?*cme-clp-files* = (create$ ;strings.clp io.clp
message-functions.clp
FIX-Recev-Common.clp FIX-Recev-EOY.clp FIX-Send-Common.clp FIX-Send-EOY.clp
cyclops_prep.clp ;inbound-cyclops2.clp interpreter_control.clp
market_data_templates.clp mdp_outbound_interpreter.clp
nsc_inbound_interpreter.clp nsc_outbound_interpreter.clp
outbound_cyclops2.clp red_modules.clp task.clp
))
(deffunction fixint (?valstr)
;(if (eq (eval ?valstr) 2147483647) then (eval (str-cat ?valstr ".0")))
(if (> (eval ?valstr) 2147483646) then (eval (str-cat ?valstr ".0")) else (eval ?valstr))
) ;a scm/lsp is really needed, too bad it can't be worked into this; I still like parts of xlips too
(deffunction numpre-p (?valstr)
(str-index (sub-string 1 1 ?valstr) "1234567890")
)
(deffunction numstr-p (?valstr)
(loop-for-count (?cnt 1 (str-length ?valstr)) do
(if (not (integerp (string-to-field (sub-string ?cnt ?cnt ?valstr))))
then (return FALSE))
) TRUE)
(deffunction fix-int (?valstr)
(if (numberp ?valstr) then ?valstr
else
(if (numstr-p ?valstr) then (fixint ?valstr) else ?valstr)
)
)
;(deffunction cmeclp2L () (map1 file2lists ?*cme-clp-files*))
;trading.clp noman_interface_templates.clp
;CLIPS> (type [Rolls-Royce])
;CAR
(deffunction class-of (?inst)
(if (instancep ?inst) then (type ?inst)
else if (class-existp ?inst) then ?inst)
)
;-both clips&jess have and and or that only return TRUE/FALSE not 1 of the values
(deffunction ptf (?v) (if ?v then T else F))
;-also warning that and of nil is still TRUE
(deffunction last$ (?l) (nth$ (length$ ?l) ?l))
(deffunction first (?l) (nth 1 ?l)) ;being redefined
(deffunction and_ ($?args)
(if (not (first $?args)) then (return FALSE) else (and_ (rest$ $?args)))
)
(deffunction and- ($?args)
(if (not ;(or ;?
(member$ FALSE ?args)
;(member$ nil ?args)) ;?
)
;if (funcall and $?args)
then (last$ ?args))
)
(deffunction andl ($?args)
(if (not (or ;?
(member$ FALSE ?args)
(member$ nil ?args)) ;?
)
then (last$ ?args))
)
(deffunction first-full ($?args)
(if (first ?args) then (first ?args) else (first-full (rest$ ?args)))
)
(deffunction or- ($?args)
(if (funcall or $?args) then (first-full ?args))
) ;lisp like or orl is below
;CLIPS> (or- nil a nil b nil c nil) nil
;CLIPS> (orl nil a nil b nil c nil) a
(deffunction nop (?a) ?a)
(deffunction funcall$ (?fnc $?args) ;makes up for the new funcall not being so great
(eval (format nil "(%s %s)" ?fnc (implode$ ?args))))
;while (loop-for-count <range-spec> [do] <action>*)
;lookat:
;TYPE: Returns a symbol which is the name of the type (or class) of its of argument.
;(type <expression>)
;-could combine w/switch to make a typecase sort of situation
;APROPOS: Displays all symbols currently defined in CLIPS which contain a specified substring
;(apropos <lexeme>)
;-new ;this should take a class too
(deffunction slot-names (?inst)
(if (instancep ?inst) then (class-slots (class ?inst) inherit)
else
(if (class-existp ?inst) then (class-slots ?inst inherit)
else (printout t crlf "[not instance or class]"))
)
)
;-LIST (consider having a next method that remember an elt iterated on)?
(defgeneric position) ;in lisp there is search also like find here.
(defgeneric write-to-string) ;from list
(defgeneric listp)
(defgeneric make-list)
(defmethod listp ((?lst MULTIFIELD)) ;LIST
TRUE)
(defmethod listp ((?lst SYMBOL (or (eq ?lst nil)
(eq ?lst NIL))))
TRUE)
(defmethod listp (?other-type)
FALSE)
(defgeneric value) ;more below
(defmethod value (?a)
?a)
;;; implementations
;lookat:
;
;SYSTEM: Appends its arguments together to form a command which is
; then sent to the operating system.
;(system <lexeme-expression>*)
(deffunction sleep (?t) (system (format nil "sleep %d" ?t)))
(deffunction s1 () (sleep 1))
;-
;CLIPS version of ACA c-util.fnc
;c-util.fnc Basic utility fns that don't depend on the *.lib files
; There are funcal/mapcar/etc fncs on list etc
;-------------------------------------------------------------
;The major efficiency issue probably comes in rewriting some of the more
;often used util fncs, so there are not any interveneing lists.
;More safty for fncs w/ different #s of slots can also be done then.
;(as an example look at the util fncs rewritten as handlers in c-util2.fnc
; more of something like this would be good.)
;-------------------------------------------------------------
;--global variables----------------------------------------------------
;these are now in c-gloabl.bnd
;(defglobal ?*pol-data-counter* = 0)
;(defglobal ?*infringement-counter* = 0)
;(defglobal ?*case-study-counter* = 0)
;(defglobal ?*qualities-counter* = 0)
;(defglobal ?*copy-counter* = 0)
;(defglobal ?*control-counter* = 0)
;;(defglobal ?*gpq* = (create$))
(defglobal ?*lp* = "(")
(defglobal ?*rp* = ")")
(defglobal ?*lp2* = "((")
(defglobal ?*rp2* = "))")
;(deffunction cons ($?args) ?args) ;generic below
;--MAKE-LAMBDA-----------------------------------------------------
(deffunction make-lambda (?lstr)
(bind ?name (gensym))
(build (str-cat "(deffunction " ?name " " ?lstr ")"))
?name)
;EVAL: Evaluates a string as though it were entered at the command prompt.
; Only allows functions to be evaluated.
;(eval <lexeme-expression>)
(deffunction eval- (?s)
(if (lexemep ?s) then (eval ?s) else ?s)
)
(deffunction eval-str (?valstr)
(eval- (fix-int ?valstr))
)
;
;BUILD: Evaluates a string as though it were entered at the command prompt.
; Only allows constructs to be evaluated.
;(build <lexeme-expression>)
;CHECK-SYNTAX: Allows the text representation of a construct or function
; call to be checked for syntax and semantic errors.
;(check-syntax <construct-or-function-string>)
;lookat:
;STRING-TO-FIELD: Parses a string and converts its contents to a primitive data type.
;(string-to-field <string-or-symbol-expression>)
;-looks like evaluate
; also upcase & lowcase
(deffunction to-lst ($?args) ?args)
;--TO-STR-----------------------------------------------------
(deffunction to-str ($?args) (implode$ ?args))
;(deffunction to-str ($?args)
; (if (stringp $?args) then (return $?args) ;fix
; else (implode$ ?args)))
;redef to-str below
;(deffunction to-str ($?args) ;below
; (str-strip-quote (implode$ ?args)))
(deffunction str ($?args) (implode$ ?args))
;CLIPS> (to-str hi there two)
;"hi there two"
;CLIPS> (str-cat hi there two)
;"hitheretwo"
(deffunction to-sym ($?s)
(funcall$ sym-cat $?s)
;(sym-cat ?s)
) ;new/fix
(deffunction multi-str-replace (?a ?b ?str) (system (str-cat "tr " ?a " " ?b " " ?str))) ;system$ but redef below
(deffunction pstr (?s)
(if (stringp ?s) then (write-to-string ?s) else ?s))
(deffunction pstr- ($?args)
(to-sym (multi-str-replace "\\" "" (multi-str-replace "\"" "" (str-cat (implode$ ?args)))))
)
(deffunction symbol ($?args)
;(to-sym (multi-str-replace "\"" "" (to-str ?args)))
;(to-sym (multi-str-replace "\\\"" "" (str-cat (implode$ ?args))))
; (to-sym (multi-str-replace "\\" "" (multi-str-replace "\"" "" (str-cat (implode$ ?args)))))
(to-sym (pstr- ?args))
)
;deffunction pad (?n ?p)
(deffunction zpad (?n ?p)
"pad, probably in format"
(bind ?s (str ?n))
(bind ?sl (length ?s))
(if (> ?p ?sl) then
(bind ?d (- ?p ?sl))
(loop-for-count (?i 1 ?d) do (bind ?s (str-cat "0" ?s))))
?s) ;CLIPS> (zpad 1 4) "0001"
;to-str could be used to create strings for msg-passing:
(deffunction paren (?s) (str-cat "(" ?s ")"))
(deffunction to-pstr ($?args) (paren (to-str ?args)))
(deffunction quotes ($?args) (paren (to-str ?args)))
(deffunction quote ($?args) (sym-cat "(" (implode$ ?args) ")"))
(deffunction quote-mf ($?args) (sym-cat "(create$ " (implode$ ?args) ")"))
(deffunction quote-list ($?args) (sym-cat "(create$ " (implode$ ?args) ")"))
(deffunction prn ($?args) (paren (to-str ?args)))
;to-pstr is similar to quote, because it isn't evaluated (but is a str)
;so it will be evaluated when eval-ed
(deffunction qins (?ps)
"clos style ins name"
(if (instancep ?ps) then (str-cat "'" (instance-name ?ps)) else ?ps)
)
(deffunction qis (?ps)
"quote if a string"
(if (stringp ?ps) then (str-cat "\"" ?ps "\"") else ?ps)
)
;STR-CAT: Concatenates its arguments to form a single string.
;(str-cat <expression>*)
;
;SYM-CAT: Concatenates its arguments to form a single symbol.
;(sym-cat <expression>*)
;
;SUB-STRING: Retrieves a subportion from a string.
;(sub-string <integer-expression> <integer-expression> <string-expression>)
;
;STR-INDEX: Returns the position of the first argument within the second argument.
;(str-index <lexeme-expression> <lexeme-expression>)
;(deffunction suffixp (?post ?str) ;new ;use for file-types
; "see if this is the end of the str"
; (bind ?l (length ?post))
; (eq (str-index ?post ?str) ?l)) ;wrong ones below better
(deffunction prefixp (?pre ?str)
"see if this is the start of the str"
(eq (str-index ?pre ?str) 1))
(deffunction prefix (?pre ?str)
"if not a prefix already, then add it"
(if (prefixp ?pre ?str) then ?str else (str-cat ?pre ?str))
)
(deffunction postfixp (?post ?str)
"see if this is the start(end) of the str"
(eq (str-index ?post ?str) (- (length ?str) (length ?post))))
;might be wrong, so try
;mvded blwo w/suffix-p
;(postfix-p "abc" "a.abc")
;TRUE
(deffunction postfix (?post ?str)
"if not a postfix already, then add it"
(if (postfixp ?post ?str) then ?str else (str-cat ?str ?post))
)
(deffunction end$ (?l ?n)
(subseq$ ?l ?n (length$ ?l)))
(deffunction ending (?post ?str)
"make sure the file ends w/[.]post"
(postfix (prefix . ?post) ?str))
(deffunction ending- (?post ?str)
"make sure the file ends w/post"
(postfix ?post ?str))
(deffunction path-cat (?p1 ?p2)
"a str-cat for2path parts"
(str-cat (ending- "/" ?p1) ?p2)
)
;suffix stuff was already just below here, but not set more mapping
;(deffunction ending-p (?str ?post)
; (if (full$ ?post) then (bind ?post (first ?post)))
; (ending ?post ?str)) ;need a -p not a str
;lookat:
;DESCRIBE-CLASS: Provides a verbose gescription of a class.
;(describe-class <class-name>)
;
(deffunction print_class (?c) (describe-class ?c)) ;specialize below
;BROWSE-CLASSES: Provides a rudimentary display of the inheritance
; relationships between a class and all its subclasses.
;(browse-classes [<class-name>]) ;taxonomy
;-should make this a method that takes a stream-obj, that could incl an external-pipe,
; look into routers/streams, and see if you could open a stream to a pipe-file anyway
;deffunction print (?p) ;mved below
;(if (instance-existp ?p) then (send ?p print))
;;(if (message-handler-existp (class ?p) print) then (send ?p print)) -no
(deffunction princ (?a)
(printout t " " ?a))
;--INCR--------------------------------------------------------
;this function takes a number and returns that number plus 1
(deffunction incrn (?v) (bind ?v (+ ?v 1)))
;this function takes a string w/ a variables name in it
;this variable is then incremented by one (used for instance counters)
(deffunction incr (?var-str ?amt)
(eval (format nil "(bind \?%s (+ \?%s %d))" ?var-str ?var-str ?amt)))
;---
(deffunction null$ (?lv)
(or (eq ?lv nil) (and (multifieldp ?lv) (= (length ?lv) 0))))
(deffunction full$ (?lv)
(if (multifieldp ?lv) then (> (length ?lv) 0) else (neq ?lv nil)))
;---
(deffunction fulll$ (?lv)
(and (multifieldp ?lv) (> (length ?lv) 0))
)
(deffunction first-full$ ($?args)
(if (full$ (first ?args)) then (first ?args) else (first-full (rest$ ?args)))
)
(deffunction orl ($?args)
(if (funcall or $?args) then (first-full$ ?args))
)
(deffunction member- (?a ?l) (if (full$ ?l) then (member$ ?a ?l))) ;new
(deffunction member-i (?i ?l) (member- (instance-name ?i) ?l)) ;Very Useful for rule tests
;--NULL----------------------------------------------------
;just like null in LISP
;(deffunction null (?a) (if (eq ?a nil) then TRUE else FALSE))
(defmethod null (?v)
(if (eq ?v nil) then TRUE else FALSE))
(defmethod null ((?l MULTIFIELD))
(if (eq (length ?l) 0) then TRUE else FALSE))
(deffunction null-lv (?a)
(if (or (and (multifieldp ?a) (eq (length ?a) 0)) (eq ?a nil)) then TRUE
else FALSE))
;deffunction nnull ($?any)
(deffunction nnull (?any)
"~like my full"
(not (null ?any)))
(deffunction full-eq (?a ?b)
"both are not null and still eq"
(and (full$ ?a) (full$ ?b) (eq ?a ?b))
)
;--FUNCALL----------------------------------------------------
;similar to funcall in LISP, except non of the arguments can be lists
;-i don't think the c-version is the same as mine below, so i'm adding the $
;(deffunction funcall$ (?fnc $?args) ;mved up
; (eval (format nil "(%s %s)" ?fnc (implode$ ?args))))
;w/out the eval this has the same effect as quotes
;--FUNCALL-L----------------------------------------------------
;similar to funcall in LISP, except only the 1st argument can be list
(deffunction funcall-l (?fnc ?l $?args)
(eval (format nil "(%s (create$ %s) %s)" ?fnc (implode$ ?l) (implode$ ?args))))
;use (expand$ )
;EXPAND$: When used inside of a function call, expands its arguments
; as separate arguements to the function. The $ operator is
; merely a shorthand notation for the expand$ function call.
;(expand$; <multifield-expression>)
;lookat:
;INSTANCE-NAME: Returns a symbol which is the name of its instance argument.
;(instance-name <instance-expression>)
;SYMBOL-TO-INSTANCE-NAME: Converts a symbol to an instance name.
;(symbol-to-instance-name <symbol-expression>)
; is a sort of ins-to-sym
;INSTANCE-NAME-TO-SYMBOL: Converts an instance name to a symbol.
;(instance-name-to-symbol <instance-name-expression>)
;
;INSTANCE-NAMEP: Returns TRUE if its argument is an instance name, FALSE otherwise.
;(instance-namep <expression>)
;------------sym-to-ins
;a form of symbol-to-instance name that can take many args
(deffunction sym-to-ins ($?n) ;s2i
"make an inst name"
(bind ?n (funcall$ sym-cat ?n)) ;another funcall change
(if (nnull ?n) then (symbol-to-instance-name ?n))
)
;-this &/or s2i below should check for nil
;check these out
(deffunction genins ()
(sym-to-ins (gensym))
)
(deffunction ins-existp ($?n)
(instance-existp (sym-to-ins ?n)))
;--LENGTH-LV----------------------------------------------------
;(deffunction length-lv (?lv)
; (if (multifieldp ?lv) then (length ?lv) else 1))
;new ;but not tripping on nil
(deffunction length-lv (?lv)
(if (and ?lv (neq ?lv nil)) then
(if (multifieldp ?lv) then (length ?lv) else 1)
else 0)
)
;--NTH1-LV----------------------------------------------------
;returns the 1st elt. if multifield or value if a value
(deffunction nth1-lv (?lv)
(if (multifieldp ?lv) then (nth$ 1 ?lv) else ?lv))
;--NTH-LV----------------------------------------------------
(deffunction nth-lv (?n ?lv)
(if (multifieldp ?lv) then (nth$ ?n ?lv) else ?lv))
;--FIRST----------------------------------------------------
(deffunction first (?lv) (nth1-lv ?lv))
; (if (multifieldp ?lv) then (first$ ?lv) else ?lv)
(deffunction second (?lv) (nth-lv 2 ?lv))
(deffunction third (?lv) (nth-lv 3 ?lv))
(deffunction fourth (?lv) (nth-lv 4 ?lv))
(deffunction fifth (?lv) (nth-lv 5 ?lv))
(deffunction sixth (?lv) (nth-lv 6 ?lv))
;(deffunction last (?lv) (if (multifiedp ?lv) (nth$ (length ?lv) ?lv) else ?lv))
(deffunction last (?lv) (nth-lv (length-lv ?lv) ?lv))
;---
(deffunction default_args (?d $?args)
(if (null$ ?args) then ?d else (first ?args))
)
;--DFLT----------------------------------------------------
(deffunction dflt (?val ?dflt)
(if (null ?val) then ?dflt else ?val))
;--NTH-DFLT----------------------------------------------------
(deffunction nth-dflt (?n ?lv ?dflt)
(dflt (nth-lv ?n ?lv) ?dflt))
(deffunction first-dflt (?lv ?dflt) (dflt (first ?lv) ?dflt))
(deffunction second-dflt (?lv ?dflt) (dflt (nth-lv 2 ?lv) ?dflt))
(deffunction third-dflt (?lv ?dflt) (dflt (nth-lv 3 ?lv) ?dflt))
(deffunction fourth-dflt (?lv ?dflt) (dflt (nth-lv 4 ?lv) ?dflt))
(deffunction fifth-dflt (?lv ?dflt) (dflt (nth-lv 5 ?lv) ?dflt))
(deffunction sixth-dflt (?lv ?dflt) (dflt (nth-lv 6 ?lv) ?dflt))
(deffunction last-dflt (?lv ?dflt) (dflt (last ?lv) ?dflt))
;CLIPS> (last (create$ a b c)) -> c
;CLIPS> (last a) -> a
;CLIPS> (last (create$)) -> nil
;CLIPS> (last-dflt (create$) b) -> b
;(deffunction first-dflt (?lv ?dflt) (nth-dflt 1 ?lv ?dflt))
;(deffunction second-dflt (?lv ?dflt) (nth-dflt 2 ?lv ?dflt))
;(deffunction third-dflt (?lv ?dflt) (nth-dflt 3 ?lv ?dflt))
(deffunction reduce-vl (?binary-fnc ?val ?list)
(if (null ?list) then (return ?val))
(reduce-vl ?binary-fnc (funcall ?binary-fnc ?val (first ?list)) (rest$ ?list))
)
(deffunction reduce$ (?binary-fnc ?list)
"from python"
(if (or (null ?list) (< (length$ ?list) 2)) then (return ?list))
(bind ?val (funcall ?binary-fnc (first ?list) (second ?list)))
(reduce-vl ?binary-fnc ?val (rest$ (rest$ ?list)))
)
;CLIPS> (reduce$ max (create$ 1 4 2 5 3)) 5
;CLIPS> (reduce$ * (create$ 1 4 2 5 3)) 120
;CLIPS> (reduce$ - (create$ 1 4 2 5 3)) -13
(deffunction ls ($?filt) ;add a path
"system ls"
(bind ?f (first-dflt ?filt ""))
(system (str-cat "ls " ?f))
);use ls$ to get the vals
(deffunction pwd () ;can use for CurrentWorkingDir
"print workind directory"
(system "pwd")
)
;(deffunction txt-files () (filter$ (ls$) ".ics")) ;rdef below filter
;-=new ;another version down in array code
(deffunction explode-str$ (?str)
"take each char of a str to a list, opposite fnc is sym-cat"
(if (listp ?str) then (bind ?str (first ?str)))
(bind ?str (to-str ?str))
(bind ?l (create$))
(loop-for-count (?i 1 (length ?str)) do
(bind ?l (create$ ?l (sub-string ?i ?i ?str)))
) ?l)
(deffunction rev$ (?lst)
(bind ?len (length$ ?lst))
(bind ?l (create$))
(loop-for-count (?i 1 ?len) do
(bind ?l (create$ (subseq$ ?lst ?i ?i) ?l))
) ?l)
;lookat: mv-subseq
;subsetp subset -same
(deffunction reverse$ (?l)
(if (> (length$ ?l) 1) then (create$ (reverse$ (rest$ ?l)) (first$ ?l))
else ?l))
(deffunction rev-str (?str)
(bind ?len (length ?str))
(bind ?rs "")
(loop-for-count (?i 1 ?len) do
(bind ?ie (- ?len ?i))
; (printout t crlf "ie:" ?ie " rs:" ?rs " ss:" (sub-string ?ie ?ie ?str))
(bind ?rs (str-cat ?rs (sub-string ?ie ?ie ?str)))
)
?rs)
;-=
(deffunction sp ($?n)
"n spaces"
(bind ?ct (first-dflt ?n 1))
(bind ?sp "")
(switch ?ct
(case 1 then " ")
(case 2 then " ")
(case 3 then " ")
(case 4 then " ")
(case 5 then " ")
(case 6 then " ")
(default (loop-for-count (?i 1 ?ct) do (bind ?sp (str-cat ?sp " "))) ?sp)
)
)
(deffunction cln-sp ($?n)
(str-cat ":" (sp ?n))
)
(deffunction str-cat-wsp ($?args)
"so you don't have to send spaces in"
(implode$ ?args)
) ;CLIPS> (str-cat-wsp a b c) "a b c"
;(deffunction str-cat-sort ($?args)
; (implode$
; ;(sort > ?args)
; (smembers$ ?args)))
;CLIPS> (str-cat-sort (create$ "c" "d" "a" "b")) ""a" "b" "c" "d""
;--IN-RANGE----------------------------------------------------
;given value & range as 2values or as a m.f. return a val that is in the range
(deffunction in-range (?value $?range) ;bound by range
(bind ?min (first-dflt ?range 0))
(bind ?max (second-dflt ?range ?value))
(if (> ?value ?max) then
(printout t "[warning " ?value " is > max of " ?max "]")
(return ?max))
(if (< ?value ?min) then
(printout t "[warning " ?value " is < min of " ?min "]")
(return ?min))
?value)
;if the in-rage call = the value then it was ok == in-range-p
;could have a version w/inst-sn & if not in range it would set it
;lookat:
;SLOT-FACETS: Returns the facet values for the specified slot of a class in a multifield value.
;(slot-facets <class-name> <slot-name>)
;
;SLOT-SOURCES: Returns the names of the classes which provide facets for a
; slot of a class in a multifield variable.
;(slot-sources <class-name> <slot-name>)
;
;SLOT-TYPES: Returns the names of the primitive types allowed for a slot
; in a multifield variable.
;(slot-types <class-name> <slot-name>)
;
;SLOT-CARDINALITY: Returns the minimum and maximum number of fields allowed
; for a multislot in a multifield variable.
;(slot-cardinality <class-name> <slot-name>)
;
;SLOT-ALLOWED-VALUES: Returns the allowed values for a slot in a
; multifield value.
;(slot-allowed-values <class-name> <slot-name>)
;
;SLOT-RANGE: Returns the minimum and maximum numeric values allowed
; for a slot.
;(slot-range <class-name> <slot-name>)
;
;SLOT-DEFAULT-VALUE: Returns the default value associated with a slot.
;(slot-default-value <class-name> <slot-name>)
;
;--SLOT-VALUE-types----------------------------------------------
;use (slot-types ?class ?slotname) right next to slot-value
(deffunction slot-value-types (?ins ?sn)
"gives the slot-types, for that ins, use near slot-value"
(slot-types (class ?ins) ?sn)
)
(deffunction slot-value-type (?ins ?sn)
"give the 1st type returned by: slot-types"
(first (slot-value-types ?ins ?sn))
)
;(deffunction slot-value-wstr (?ins ?sn)
; "get it ready to print"
; (bind ?sv (slot-value ?ins ?sn))
; (if (member STRING (slot-value-types ?ins ?sn)) then
; (bind ?sv (quote ?sf)))
;?sf)
;--SLOT-VALUE----------------------------------------------------
(deffunction slot-get (?ins ?sn)
"jess compat"
(send ?ins (sym-cat get- ?sn))
)
(deffunction slot-value (?ins ?sn)
(if (slot-existp (class ?ins) ?sn inherit) then (slot-get ?ins ?sn)
else (printout t "[slot-value " ?ins " does not have a " ?sn " slot]")
(return FALSE)) ;new
)
;-
(deffunction slot-value-wstr (?ins ?sn)
"use LIST method to dispatch on type, for a writable str"
(write-to-string (slot-value ?ins ?sn))
)
;
;(deffuntion ins-wstrs (?ins)
; (bind ?cls (class-of ?ins))
; (map1 slot-value-wstr ..)
;)
(deffunction try ($?args)
"jess compat" ;no macros so doesn't work
(printout t "clips can not TRY:" ?args)
)
;--SLOT-PUT-VALUE---------------------------------------------
(deffunction slot-set (?ins ?sn ?val) ;the setter for slot-value
"jess compat"
(send ?ins (sym-cat put- ?sn) ?val)
)
(deffunction slot-put-value (?ins ?sn ?val) ;the setter for slot-value
(if (slot-existp (class ?ins) ?sn inherit) then
(slot-set ?ins ?sn ?val)
else (printout t "[slot-put-value " ?ins " does not have a " ?sn " slot]")))
;might need to check if write access & if val=mf then if slot-facet1=MLT
(deffunction slot-allowed-value-p (?class ?sn ?val) ;the checker for slot-put-value- or sav
(if (not (class-existp ?class)) then (printout t crlf "no class:" ?class crlf) (return nil))
(bind ?a (slot-allowed-values ?class ?sn))
(and (fulll$ ?a) (member$ ?val ?a))
) ;but it is a class of values, so a specific val vs a class won't work, fix
;-;can use this new one to incr/decr, ins-name to ins-address etc
(deffunction slot-update-fnc (?ins ?sn ?fnc)
"reset the value w/the present val as input to fnc"
(slot-put-value ?ins ?sn (funcall ?fnc (slot-value ?ins ?sn))))
;-
(defmessage-handler OBJECT slot-ref2addr (?sn)
; (bind ?self:?sn (instance-address ?self ?sn))
(slot-put-value ?self ?sn (instance-address ?self ?sn))
)
;-
;(deffunction slot-allowed-classes (?c ?sn)
; "for jess compat" ;this won't work well; I need a better(dbg)fix
; (printout t "[WARN:clpOnlyHasAllowedValuesNow:" ?c "," ?sn)
; (slot-allowed-values ?c ?sn) ;make sure it's a multifield
;) 6.2.4 has this now
;checking allowed-value before a put, then setting an error slot/facet if it is off&needs recording
;-this could kick off other (generic)function-ality
(deffunction sav- (?ins ?sn ?val) ;the setter for slot-value
(if (instance-existp ?ins) then (bind ?class (class-of ?ins)) else (return nil))
(if (slot-existp ?class ?sn inherit) then
(if (slot-allowed-value-p ?class ?sn ?val) then (send ?ins (sym-cat put- ?sn) ?val)
else (printout t "[slot-put-value " ?ins "," ?sn " slot, unallowed-val:" ?val
":" (slot-allowed-values ?ins ?sn) "]"))
else (printout t "[slot-put-value " ?ins " does not have a " ?sn " slot]"))
)
(deffunction sav (?ins ?sn ?val) ;the setter for slot-value
(if (instance-existp ?ins) then (slot-put-value ?ins ?sn ?val))
)
;lookat:
;DELETE-MEMBER$: Deletes specific values contained within a multifield
; value and returns the modified multifield value.
;(delete-member$ <multifield-expression> <expression>+)
;
;REPLACE-MEMBER$: Replaces specific values contained within a multifield
; value and returns the modified multifield value.
;(replace-member$ <multifield-expression> <substitute-expression> <search-expression>+)
;-also my subset-val looks like member
;--REPLACE----------------------------------------------------
;a version of replace$ that will append if out of range
(deffunction replace (?l ?a1 ?a2 ?l2)
(bind ?ml (length$ ?l))
(bind ?n1 (min ?a1 ?ml))
(bind ?n2 (min ?a2 ?ml))
(if (neq ?a1 ?n1) then (bind ?l2 (create$ (nth$ ?ml ?l) ?l2)))
(replace$ ?l ?n1 ?n2 ?l2))
;--SLOT-REPLACE-----------------------------------------------
;(deffunction replace-mslot-value (?inst ?slot ?a1 ?a2 ?l2)
; (bind ?l (slot-value ?inst ?slot))
; (if (not (multifieldp ?l)) then (bind ?l (create$ ?l)))
; (slot-put-value ?inst ?slot (replace ?l ?a1 ?a2 ?l2)))
(deffunction slot-replace (?inst ?slot ?a1 ?a2 ?l2)
(bind ?l (slot-value ?inst ?slot)) ;list w/ values to replace (append)
(bind ?ml (length$ ?l)) ;it's lenght
(bind ?n1 (min ?a1 ?ml)) ;make sure that the replace bounds <= ml
(bind ?n2 (min ?a2 ?ml)) ;if >then append
;if lower replace bnd > ml, then insert end of old list at begin of new
; so when it replaces the end of the old, that elt won't be lost
;(if (neq ?a1 ?n1) then (bind ?l2 (create$ (nth$ ?ml ?l) ?l2)))
(if (neq ?a1 ?n1) then (bind ?l2 (create$ (nth$ ?ml ?l) ?l2)))
(slot-replace$ ?inst ?slot ?n1 ?n2 ?l2))
;--APPEND----------------------------------------------------
;see mv-append and mv-delete also
(defgeneric append)
(defmethod append (?l ?a) ;generic below
(insert$ ?l (+ 1 (length$ ?l)) ?a)) ;could use create$ too
(defgeneric nconc)
(defmethod nconc (?l ?a) (append ?l ?a)) ;w/o ins, it won't know the diff?
;--SLOT-APPEND-----------------------------------------------
(deffunction slot-append (?inst ?slot ?a)
(slot-insert$ ?inst ?slot (+ 1 (length$ (slot-value ?inst ?slot))) ?a))
;I need a version that doesn't add if it is the same thing, also from hw2
;(deffunction slot-append-new (?ins ?slot ?a)
; (if (not (member$ ?a (slot-value ?ins ?slot))) then
; (slot-append ?ins ?slot ?a)))
(deffunction slot-append-new (?ins ?slot ?a)
(if (member$ ?a (bind ?l (slot-value ?ins ?slot))) then ?l ;so always get ?l back
else (slot-append ?ins ?slot ?a)))
(deffunction slot-put-values (?inst ?slot $?args)
(slot-append ?inst ?slot ?args)
)
;new
(deffunction remove$ (?a ?l)
(if (bind ?e-index (member$ ?a ?l)) then
(bind ?l (delete$ ?l ?e-index ?e-index))
(bind ?l (remove$ ?a ?l)) ;once more to rm extras
)
?l)
(deffunction slot-remove$ (?ins ?sn ?a)
(bind ?l (slot-value ?ins ?sn))
(if (bind ?e-index (member$ ?a ?l)) then
(bind ?l (slot-delete$ ?ins ?sn ?e-index ?e-index))
(bind ?l (slot-remove$ ?ins ?sn ?a)) ;once more to rm extras
)
?l) ;here the main (side) effect is in the ins
(deffunction remove1 (?a ?l)
(progn$ (?e ?l)
(if (eq ?a ?e) then (bind ?l (delete$ ?l ?e-index ?e-index)))
)
?l)
(deffunction remove2$ (?a ?l)
"remove all of the a's from the list" ;doesn't work w/>1 ?a
(bind ?rl (create$))
(progn$ (?e ?l)
(if (neq ?a ?e) then (bind ?rl (create$ ?rl ?e)) )
)
?rl)
;new
(deffunction slot-swap (?i1 ?i2 ?sn)
"swap values"
(bind ?v1 (slot-value ?i1 ?sn))
(bind ?v2 (slot-value ?i2 ?sn))
(slot-put-value ?i1 ?sn ?v2)
(slot-put-value ?i2 ?sn ?v1)
)
;--REST-LV----------------------------------------------------
;returns the rest of the elts. if multifield or value if a value
(deffunction rest-lv (?lv)
(if (multifieldp ?lv) then (rest$ ?lv) else ?lv))
;new version below to handle LIST too
(deffunction range- (?start ?end)
"a version of range callable by it, that does reverse ranges";so can just call range to get it
(if (not (and (numberp ?start) (numberp ?end) (< ?end ?start))) ;could use in-range
then (printout t "bad range" ?start ":" ?end))
(bind ?max (+ ?start ?end))
(bind ?r (create$))
(loop-for-count (?i ?end ?start) do (bind ?r (append ?r (- ?max ?i))))
?r)
(deffunction range (?start ?end)
"from python"
;if (not (and (numberp ?start) (numberp ?end) (< ?start ?end))) ;could use in-range
(if (not (and (numberp ?start) (numberp ?end))) ;could use in-range
then (printout t "bad range" ?start ":" ?end))
(if (> ?start ?end) then (return (range- ?start ?end)))
;if (= ?start ?end) then
(bind ?r (create$))
(loop-for-count (?i ?start ?end) do (bind ?r (append ?r ?i)))
?r)
(deffunction range1 (?end) (range 1 ?end))
;I coud call range then map over it, or:
;deffunction range-f (?start ?end ?fnc)
;-
;deffunction map-class (?class ?f1 ?lv1 $?args)
(deffunction map-class (?f1 ?class $?args)
"map over all instances of the class"
(do-for-all-instances ((?i ?class))
TRUE
;(funcall ?f1 ?i ?lv1 ?args)
(funcall ?f1 ?i ?args)
)
)
(deffunction map_class (?f1 ?class $?args)
(if (full$ ?args) then (map-class ?f1 ?class ?args)
else (do-for-all-instances ((?i ?class)) TRUE
(funcall ?f1 ?i))))
;==MAP===APPLY=========
;add $?args (for flexability)
;then map# would be themax # of lists & min # of total arguments
;use (progn$ )
;--MAP1--APPLY1--------------------------------------------------
;takes a function and at least 1 argument, but not more than 1 list
;then acts like LISP's mapcar, returning a multifield of the results
(deffunction map1 (?f1 ?lv1 $?args)
(if (not (multifieldp ?lv1)) then
(printout t "[no mf]")
(return (funcall ?f1 ?lv1 ?args)))
(if (eq (create$ ) ?lv1) then (create$ ) else ;clean this
(create$ (funcall$ ?f1 (nth1-lv ?lv1) ?args)
(map1 ?f1 (rest-lv ?lv1) ?args)))) ;should i pass as $?args
(deffunction map1send (?f1 ?lv1 $?args)
"should make a lambda if i could"
(if (not (multifieldp ?lv1)) then
(printout t "[no mf]")
(return (send ?lv1 ?f1 ?args)))
(if (eq (create$ ) ?lv1) then (create$ ) else ;clean this
(create$ (send (nth1-lv ?lv1) ?f1 ?args)
(map1 ?f1 (rest-lv ?lv1) ?args)))) ;should i pass as $?args
;deffunction foreach (?tv ?lv1 ?f1 $?args) ;also in newest clips so had2fix
(deffunction for-each ( ?lv1 ?f1 $?args)
"for jess compatability"
(map1 ?f1 ?lv1 ?args)
)
;(deffunction agendas () (foreach ?m (get-focus-stack) (agenda ?m))) ;not completely compatable
(deffunction agendas () (for-each (get-focus-stack) agenda))
;try june-04
(deffunction map-1 (?f1 ?lv1 $?args)
"map that works w/o a list, as a funcall alone"
(if (not (multifieldp ?lv1)) then (funcall ?f1 ?lv1 $?args)
else (map1 ?f1 ?lv1 $?args)))
(deffunction rmap1 (?fnc ?l $?args) ;might want to call rmap-1
"recursive map-1"
(if (null ?l) then (return))
(create$ ;as it isn't just apply
(bind ?v (map-1 ?fnc ?l $?args)) ;make a fnc w/side effect that does the same thing
(rmap1 ?fnc ?v $?args)
)
)
(deffunction map1i (?f1 ?lv1 $?args)
"progn$ that has -index as 2nd arg"
(if (not (multifieldp ?lv1)) then
(printout t "[no mf]")
(return (funcall ?f1 ?lv1 ?args)))
(progn$ (?v ?lv1) (funcall ?f1 ?v ?v-index ?args))
)
(deffunction map1$ (?f1 ?lv1 $?args)
"maybe more efficient than map1, by using progn$"
(if (not (multifieldp ?lv1)) then
(printout t "[no mf]")
(return (funcall ?f1 ?lv1 ?args)))
(progn$ (?v ?lv1) (funcall$ ?f1 ?v ?args)) ;not a real map, as doesn't ret a list
)
(deffunction pris (?any ?i ?s) ;do I have a map that will send the -index down too?
(printout t ?s ?i ": " ?any crlf)
);use
;CLIPS> (map1i pris (create$ a b) num-lv)
;num-lv1: a
;num-lv2: b
;lookat:
;CLASS-EXISTP: Returns TRUE if the specified class is defined, FALSE otherwise.
;(class-existp <class-name>)
;
;SUPERCLASSP: Returns TRUE if the 1st class is a superclass of the second class, FALSE otherwise.
;(superclassp <class1-name> <class2-name>)
;
;SUBCLASSP: Returns TRUE if the first class is a subclass of the second class, FALSE otherwise.
;(subclassp <class1-name> <class2-name>)
;CLASS-SUPERCLASSES: Returns the names of the direct superclasses of a class in
; a multifield variable. If the optional "inherit" argument
; is given, indirect superclasses are also included.
;(class-superclasses <class-name> [inherit])
;
;CLASS-SUBCLASSES: Returns the names of the direct subclasses of a class in a
; multifield variable. If the optional "inherit" argument is
; given, indirect subclasses are also included.
;-a use of it w/o side effect
(deffunction class-supers (?class)
"collect all supers into a flat list"
(rmap1 class-superclasses ?class)
)
(deffunction class-subs (?class)
"collect all subs into a flat list, like w/inherit"
(rmap1 class-subclasses ?class)
)
;now something that will have the side effect of printing out sub -> super at each step
;class-super-fnc class-sub-fnc ;same return so can recurse the same as above
(deffunction class-super-fnc (?class ?fnc)
(bind ?r (remove-duplicates (class-superclasses ?class)))
(map-1 ?fnc ?r ?class)
?r)
(deffunction class-sub-fnc (?class ?fnc)
(bind ?r (remove-duplicates (class-subclasses ?class)))
(map-1 ?fnc ?r ?class)
?r
)
;p-sup-sub p-sub-sup
(deffunction p-sup-sub (?sup ?sub)
(printout t crlf ?sup " -> " ?sub)
)
(deffunction p-sub-sup (?sub ?sup)
(printout t crlf ?sup " -> " ?sub)
)
;
(deffunction class-sup-dot (?class)
(bind ?class (to-lst ?class))
(rmap1 class-super-fnc ?class p-sub-sup)
)
(deffunction class-sub-dot (?class)
(bind ?class (to-lst ?class))
(rmap1 class-sub-fnc ?class p-sup-sub)
)
(deffunction local-slotnames (?bad) );redef below
(deffunction p-clos-slt (?sn)
;(printout t crlf " (" ?sn " :initarg :" ?sn " :initform nil)") ;instead of :accessor
(printout t crlf " (" ?sn " :initarg :" ?sn " :reader get-" ?sn " :writer put-" ?sn " :initform nil)")
)
(deffunction p-clos-cls (?sub ?sup)
;(printout t crlf "(Define-Class " ?sub " has (" ?sup ")" (local-slotnames ?sub) ")")
(if (member$ ?sub ?*tlst*)
;(tlst-get clos-tax ?sub) ;(member ?sub [clos-tax]) ;(bag-get ?sub clos-tax)
then (return)) ;for now
(printout t crlf "(def-named-kb-class " ?sub " (" ?sup ") (")