├── README ├── backend-utils ├── backend-utils.shen └── module.shen ├── binary ├── bytevector.shen ├── math.shen ├── module.shen ├── native.lisp └── stream.shen ├── calendar ├── calendar.pdf ├── calendar.shen └── module.shen ├── defstruct ├── defstruct.shen └── module.shen ├── dict └── dict.shen ├── ffi ├── ffi.pdf ├── ffi.shen └── module.shen ├── file-system └── file-system.shen ├── for-expression ├── for-expression.shen └── module.shen ├── graph ├── generation.shen ├── graph.shen └── randon-geometric-graph.shen ├── html └── html.shen ├── macros └── macros.shen ├── maths ├── Maths Library.pdf ├── macro-def.shen ├── maths-functions.pdf ├── maths-lib.shen └── module.shen ├── modulesys.shen ├── modulesys_howto.md ├── packages └── packages.shen ├── pattern-matching ├── module.shen └── pattern-matching.shen ├── regexp └── regexp.shen ├── sequence └── sequence.shen ├── strings ├── auxiliary.shen ├── macro-def.shen ├── module.shen ├── str-lib.shen ├── strings.pdf └── ustring.shen ├── utils └── defpackage.shen ├── vectors-mt ├── module.shen ├── vectors.pdf └── vectors.shen └── vectors └── vectors.shen /README: -------------------------------------------------------------------------------- 1 | This is a repository of experimental Shen libraries. 2 | 3 | Shen is modern rapidly developing programming language (more precisely - 4 | metalanguage) created by Dr. Mark Tarver for all modern platforms (Python, 5 | JavaScript, Scheme, Common Lisp and many others). 6 | It combines functional programming, pattern-matching, compiler-compiler, 7 | declarative programming (almost one-to-one as in prolog) the most powerful 8 | type system in one single, and a compact and crossplatform core. 9 | You may found more information about Shen on http://www.shenlanguage.org. 10 | Information about Shen's predecessor Qi is on http://www.lambdassociates.org. 11 | 12 | If you want to share your code with other Shen users then write to 13 | vasil.s.d AT gmail.com for details how to do it. 14 | 15 | Your patches, suggestions, remarks are always welcome. 16 | 17 | 18 | Vasil S. Diadov 19 | -------------------------------------------------------------------------------- /backend-utils/backend-utils.shen: -------------------------------------------------------------------------------- 1 | (package backend-utils [kl-from-shen] 2 | 3 | (define def-string-translate-fn-aux 4 | _ [] Acc -> Acc 5 | Name [[From To] | Defs] Acc 6 | -> (let S (protect S) 7 | A (intern "Acc") 8 | X [[@s From S] A -> [do [output "c: ~A~%" From] [Name S [cn A To]]]] 9 | (def-string-translate-fn-aux Name Defs (append X Acc)))) 10 | 11 | (define def-string-translate-fn 12 | Name Defs -> (let N (intern (cn (str Name) "*")) 13 | C (protect C) 14 | S (protect S) 15 | 'Acc' (intern "Acc") 16 | A1 [[@s C S] 'Acc' -> [N S [cn 'Acc' C]]] 17 | A ["" (protect Acc) -> (protect Acc)] 18 | A (append A (def-string-translate-fn-aux N Defs A1)) 19 | X [define N | A] 20 | X)) 21 | 22 | (defmacro def-string-translate 23 | [def-string-translate Name | Defs] -> (def-string-translate-fn Name Defs)) 24 | 25 | (define kl-from-shen 26 | X -> (let X (shen.walk (function macroexpand) X) 27 | X (if (shen.packaged? X) 28 | (shen.package-contents X) 29 | X) 30 | (shen.elim-def (shen.proc-input+ X)))) 31 | 32 | (define try 33 | Code Finally -> (let R (trap-error (thaw Code) 34 | (/. E (do (thaw Finally) 35 | (error (error-to-string E))))) 36 | . (thaw Finally) 37 | R)) 38 | 39 | (define str-from-sexpr 40 | How X -> (let M (value *maximum-print-sequence-size*) 41 | . (set *maximum-print-sequence-size* -1) 42 | S (trap-error (make-string How X) 43 | (/. E (do (set *maximum-print-sequence-size* M) 44 | (error (error-to-string E))))) 45 | . (set *maximum-print-sequence-size* M) 46 | S)) 47 | 48 | (define with-file-output 49 | File Fn -> (let F (open File out) 50 | (try (freeze (Fn F)) 51 | (freeze (close F))))) 52 | 53 | (define write-file 54 | X To -> (let . (with-file-output To (/. S (pr (if (string? X) 55 | X 56 | (make-string "~A" X)) 57 | S))) 58 | true)) 59 | 60 | (define map-shen 61 | _ [] _ -> true 62 | Fn [X | Y] To -> (let X' (Fn (kl-from-shen X)) 63 | S (if (string? X') 64 | X' 65 | (make-string "~A" X')) 66 | . (pr S To) 67 | (map-shen Fn Y To))) 68 | 69 | (define translate-to-file 70 | To Head Fn Tail X -> (with-file-output 71 | To 72 | (/. F 73 | (do (Head F) 74 | (map-shen Fn X F) 75 | (Tail F) 76 | true)))) 77 | ) 78 | -------------------------------------------------------------------------------- /backend-utils/module.shen: -------------------------------------------------------------------------------- 1 | (register-module [[name: backend-utils] 2 | [load: "backend-utils.shen"]]) 3 | -------------------------------------------------------------------------------- /binary/bytevector.shen: -------------------------------------------------------------------------------- 1 | (define bytevector 2 | N -> (vector N)) 3 | 4 | (define <-bytevector-u8 5 | V I -> (<-vector V (+ I 1))) 6 | 7 | (define bytevector-u8-> 8 | B I X -> (vector-> B (+ I 1) X)) 9 | 10 | (define bytevector<-list' 11 | [] V _ -> V 12 | [X | Xs] V I -> (do (bytevector-u8-> V I X) 13 | (bytevector<-list' Xs V (+ I 1)))) 14 | 15 | (define bytevector<-list 16 | List -> (let N (length List) 17 | V (bytevector N) 18 | (bytevector<-list' List V 0))) 19 | 20 | (define list<-bytevector' 21 | V N N Acc -> (reverse Acc) 22 | V I N Acc -> (list<-bytevector' V (+ I 1) N [(<-bytevector-u8 V I) | Acc])) 23 | 24 | (define list<-bytevector 25 | V -> (list<-bytevector' V 0 (bytevector-length V) [])) 26 | 27 | (define bytevector-length 28 | V -> (limit V)) 29 | 30 | (define bytevector-copy 31 | V -> (let N (bytevector-length V) 32 | New (bytevector N) 33 | . (bytevector-replace! New 0 V 0 N) 34 | New)) 35 | 36 | (define bytevector-replace!' 37 | Dst Dst-i Src Src-i N N -> true 38 | Dst Dst-i Src Src-i I N -> 39 | (do (bytevector-u8-> Dst Dst-i (<-bytevector-u8 Src Src-i)) 40 | (bytevector-replace!' Dst (+ Dst-i 1) Src (+ Src-i 1) (+ I 1) N))) 41 | 42 | (define move-subbytevector!- 43 | V I1 I2 N N -> true 44 | V I1 I2 I N -> (do (bytevector-u8-> V I1 (<-bytevector-u8 V I2)) 45 | (move-subbytevector+!' V (- I1 1) (- I2 1) (+ I 1) N))) 46 | 47 | (define move-subbytevector! 48 | V I I N -> true 49 | V I1 I2 N -> (bytevector-replace!' V I1 V I2 0 N) where (< I1 I2) 50 | V I1 I2 N -> (move-subbytevector!- V (- (+ I1 N) 1) (- (+ I2 N) 1) 0 N)) 51 | 52 | (define bytevector-replace! 53 | V Dst-off V Src-off Len -> (move-subbytevector! V Dst-off Src-off Len) 54 | Dst Dst-off Src Src-off Len -> (bytevector-replace!' 55 | Dst Dst-off Src Src-off 0 Len)) 56 | 57 | (define bytevector-u16le-> 58 | B I X -> (do (vector-> B (+ I 1) (binary.int#0 X)) 59 | (vector-> B (+ I 2) (binary.int#1 X)))) 60 | 61 | (define bytevector-u32le-> 62 | B I X -> (do (vector-> B (+ I 1) (binary.int#0 X)) 63 | (vector-> B (+ I 2) (binary.int#1 X)) 64 | (vector-> B (+ I 3) (binary.int#2 X)) 65 | (vector-> B (+ I 4) (binary.int#3 X)))) 66 | -------------------------------------------------------------------------------- /binary/math.shen: -------------------------------------------------------------------------------- 1 | (package binary [mod div power even?] 2 | (define arithmetic-shift' 3 | X 0 -> X 4 | X S -> (arithmetic-shift' (* X 2) (- S 1))) 5 | 6 | (define arithmetic-shift 7 | X 0 -> X 8 | X S -> (arithmetic-shift-+ X S) where (> S 0) 9 | X S -> (div X (power 2 (- 0 S)))) 10 | 11 | (define bitwise-and' 12 | 0 _ R _ -> R 13 | _ 0 R _ -> R 14 | X Y R L -> (bitwise-and' (div X 2) (div Y 2) R (* L 2)) 15 | where (or (even? X) (even? Y)) 16 | X Y R L -> (bitwise-and' (div X 2) (div Y 2) (+ R L) (* L 2))) 17 | 18 | (define bitwise-and 19 | X Y -> (bitwise-and' X Y 0 1)) 20 | 21 | (define bitwise-ior' 22 | 0 0 R _ -> R 23 | X Y R L -> (bitwise-ior' (div X 2) (div Y 2) R (* L 2)) 24 | where (and (even? X) (even? Y)) 25 | X Y R L -> (bitwise-ior' (div X 2) (div Y 2) (+ R L) (* L 2))) 26 | 27 | (define bitwise-ior 28 | X Y -> (bitwise-ior' X Y 0 1)) 29 | 30 | (define int#n 31 | X 0 -> (mod X 256) 32 | X N -> (let Y (power 256 N) 33 | (div (mod X (* Y 256)) Y))) 34 | 35 | (define int#0 36 | X -> (mod X 256)) 37 | 38 | (define int#1 39 | X -> (div (mod X 65536) 256)) 40 | 41 | (define int#2 42 | X -> (div (mod X 16777216) 65536)) 43 | 44 | (define int#3 45 | X -> (div (mod X 4294967296) 16777216)) 46 | 47 | ) 48 | -------------------------------------------------------------------------------- /binary/module.shen: -------------------------------------------------------------------------------- 1 | (register-module [[depends: "maths" "defstruct"] 2 | [desc: "Binary serialization."] 3 | [load-fn: binary.load] 4 | [translate: "math.shen" "bytevector.shen" "binary.shen"]]) 5 | 6 | \* load native definitions of binary functions for efficiency *\ 7 | (define binary.load-native 8 | "Common Lisp" _ -> (do (load "bytevector.shen") 9 | ((protect LOAD) (cn (value *home-directory*) 10 | "native.lisp"))) 11 | _ _ -> (do (load "math.shen") 12 | (load "bytevector.shen"))) 13 | 14 | (define binary.load 15 | _ -> (do 16 | (binary.load-native (language) (implementation)) 17 | (load "stream.shen") 18 | true)) 19 | -------------------------------------------------------------------------------- /binary/native.lisp: -------------------------------------------------------------------------------- 1 | (DEFUN binary.arithmetic-shift (X S) 2 | (ASH X S)) 3 | 4 | (DEFUN binary.bitwise-and (X Y) 5 | (LOGAND X Y)) 6 | 7 | (DEFUN binary.bitwise-ior (X Y) 8 | (LOGIOR X Y)) 9 | 10 | (DEFUN binary.int#n (X N) 11 | (IF (ZEROP N) 12 | (LOGAND X 255) 13 | (LOGAND (ASH X (* -8 N)) 255))) 14 | 15 | (DEFUN binary.int#0 (X) 16 | (LOGAND X 255)) 17 | 18 | (DEFUN binary.int#1 (X) 19 | (LOGAND (ASH X -8) 255)) 20 | 21 | (DEFUN binary.int#2 (X) 22 | (LOGAND (ASH X -16) 255)) 23 | 24 | (DEFUN binary.int#3 (X) 25 | (LOGAND (ASH X -24) 255)) 26 | 27 | (DEFUN bytevector (N) 28 | (MAKE-ARRAY N :ELEMENT-TYPE '(UNSIGNED-BYTE 8))) 29 | 30 | (DEFUN <-bytevector-u8 (V I) 31 | (AREF V I)) 32 | 33 | (DEFUN bytevector-u8-> (V I X) 34 | (SETF (AREF V I) X)) 35 | 36 | (DEFUN bytevector-length (V) 37 | (LENGTH V)) 38 | 39 | (DEFUN bytevector-replace! (Dst Dst-i Src Src-i N) 40 | (REPLACE Dst Src :START1 Dst-i :END1 (+ Dst-i N) :START2 Src-i)) 41 | 42 | (DEFUN bytevector-u16le-> (V I X) 43 | (SETF (AREF V I) (binary.int#0 X)) 44 | (SETF (AREF V (+ I 1)) (binary.int#1 X))) 45 | 46 | (DEFUN bytevector-u32le-> (V I X) 47 | (SETF (AREF V I) (binary.int#0 X)) 48 | (SETF (AREF V (+ I 1)) (binary.int#1 X)) 49 | (SETF (AREF V (+ I 2)) (binary.int#2 X)) 50 | (SETF (AREF V (+ I 3)) (binary.int#3 X))) 51 | 52 | (DEFUN bytevector<-list (list) 53 | (LET* ((n (LENGTH list)) 54 | (v (bytevector n))) 55 | (DO ((i 0 (+ i 1)) 56 | (x list (CDR x))) 57 | ((NULL x) v) 58 | (bytevector-u8-> v i (CAR x))))) 59 | -------------------------------------------------------------------------------- /binary/stream.shen: -------------------------------------------------------------------------------- 1 | (package binary [bytevector bytevector-length bytevector-copy 2 | bytevector-replace! <-bytevector-u8 bytevector-u8-> 3 | bytevector-u16le-> bytevector-u32le->] 4 | 5 | (define uint8? X -> (<= X 255)) 6 | (define uint16? X -> (<= X 65535)) 7 | (define uint32? X -> (<= X 4294967296)) 8 | (define uint64? X -> (<= X 18446744073709551615)) 9 | 10 | (define int8? X -> (and (>= X -128) (<= X 127))) 11 | (define int16? X -> (and (>= X -32768) (<= X 32767))) 12 | (define int32? X -> (and (>= X -2147483648) (<= X 2147483647))) 13 | (define int64? X -> (and (>= X -9223372036854775808) 14 | (<= X 9223372036854775807))) 15 | 16 | (defstruct bytestream 17 | (size number) 18 | (blocks (list bytevector))) 19 | 20 | (define mkstream 21 | -> (mk-bytestream 0 [])) 22 | 23 | (define bytestream-add-block! 24 | Block Stream -> (let N (bytevector-length Block) 25 | Blocks (bytestream-blocks Stream) 26 | Size (bytestream-size Stream) 27 | . (bytestream-blocks-> Stream [Block | Blocks]) 28 | . (bytestream-size-> Stream (+ N Size)) 29 | Stream)) 30 | 31 | (define stream-blocks-to-bytevector 32 | V [] Off -> V 33 | V [B | Bs] Off -> (let Bn (bytevector-length B) 34 | . (bytevector-replace! V Off B 0 Bn) 35 | (stream-blocks-to-bytevector V Bs (+ Off Bn)))) 36 | 37 | (define bytevector-bytestream-> 38 | V Stream Off -> (let Blocks (reverse (bytestream-blocks Stream)) 39 | (stream-blocks-to-bytevector V Blocks Off))) 40 | 41 | (define bytevector-from-bytestream 42 | Stream -> (let V (bytevector (bytestream-size Stream)) 43 | (bytevector-bytestream-> V Stream 0))) 44 | 45 | (define put-u8 46 | X Stream -> (let V (bytevector 1) 47 | . (bytevector-u8-> V 0 X) 48 | (bytestream-add-block! V Stream))) 49 | 50 | (define put-i8 51 | X Stream -> (put-u8 X Stream)) 52 | 53 | (define put-u16 54 | X Stream -> (let V (bytevector 2) 55 | . (bytevector-u16le-> V 0 X) 56 | (bytestream-add-block! V Stream))) 57 | 58 | (define put-i16 59 | X Stream -> (put-u16 X Stream)) 60 | 61 | (define put-u32 62 | X Stream -> (let V (bytevector 4) 63 | . (bytevector-u32le-> V 0 X) 64 | (bytestream-add-block! V Stream))) 65 | 66 | (define put-i32 67 | X Stream -> (put-u32 X Stream)) 68 | 69 | (define put-uint 70 | X Stream -> (put-u8 X Stream) where (< X 256) 71 | X Stream -> (put-u16 X Stream) where (< X 65536) 72 | X Stream -> (put-u24 X Stream) where (< X 166777216) 73 | X Stream -> (put-u32 X Stream) where (< X 4294967296) 74 | X _ -> (error "Integer overflow: ~A > 2**32" X)) 75 | 76 | (define str-bytelen' 77 | S I -> (trap-error (do (pos S I) 78 | (str-bytelen' S (+ I 1))) 79 | (/. E I))) 80 | 81 | (define str-bytelen 82 | S -> (str-bytelen' S 0)) 83 | 84 | (define bytevector-substring->' 85 | V _ _ _ N N -> V 86 | V V-off S S-off I N -> 87 | (do (bytevector-u8-> V V-off (string->n (pos S S-off))) 88 | (bytevector-substring->' V (+ V-off 1) S (+ S-off 1) (+ I 1) N))) 89 | 90 | (define bytevector-substring-> 91 | V V-off S S-off N -> (bytevector-substring->' V V-off S S-off 0 N)) 92 | 93 | (define bytevector-string-> 94 | V Off S -> (bytevector-substring-> V Off S 0 (str-bytelen S))) 95 | 96 | (define put-string 97 | S Stream -> (let N (str-bytelen S) 98 | V (bytevector-substring-> (bytevector N) 0 S 0 N) 99 | (bytestream-add-block! V Stream))) 100 | 101 | (define put-bytevector 102 | X Stream -> (bytestream-add-block! (bytevector-copy X) Stream)) 103 | 104 | (define put-bytestream' 105 | [] Stream -> Stream 106 | [B | Bs] Stream -> (do (bytestream-add-block! B Stream) 107 | (put-bytestream' Bs Stream))) 108 | 109 | (define put-bytestream 110 | X Stream -> (put-bytestream' (reverse (bytestream-blocks X)) Stream)) 111 | 112 | (define string-from-bytevector' 113 | N N V S -> S 114 | I N V S -> (let S (cn S (n->string (<-bytevector-u8 V I))) 115 | (string-from-bytevector' (+ I 1) N V S))) 116 | 117 | (define string-from-bytevector 118 | I N V -> (string-from-bytevector' I N V "")) 119 | 120 | (define string-from-buf 121 | B -> (string-from-bytevector 1 (+ (buf-size B) 1) (buf-buf B))) 122 | 123 | (define str-from-list' 124 | [] S -> S 125 | [X | Y] S -> (str-from-list' Y (cn S (n->string X)))) 126 | 127 | (define str-from-list 128 | L -> (str-from-list' L "")) 129 | 130 | (define write-subbytevector' 131 | V Off N N F -> true 132 | V Off I N F -> (do (write-byte (<-bytevector-u8 V Off) F) 133 | (write-subbytevector' V (+ Off 1) (+ I 1) N F))) 134 | 135 | (define write-subbytevector 136 | V Off N F -> (write-subbytevector' V Off 0 N F)) 137 | 138 | (define write-bytestream' 139 | [] _ -> true 140 | [B | Bs] F -> (do (write-subbytevector B 0 (bytevector-length B) F) 141 | (write-bytestream' Bs F))) 142 | 143 | (define write-bytestream 144 | Stream F -> (write-bytestream' (reverse (bytestream-blocks Stream)) F)) 145 | 146 | (define call-with-output-file 147 | File Proc -> (let F (open File out) 148 | R (trap-error (Proc F) 149 | (/. E (do (close F) 150 | (error (error-to-string E))))) 151 | . (close F) 152 | R)) 153 | 154 | (define bytevector-to-file 155 | File V -> (call-with-output-file 156 | File 157 | (write-subbytevector V 0 (bytevector-length V)))) 158 | 159 | (define bytestream-to-file 160 | File Stream -> (call-with-output-file 161 | File (/. F (write-bytestream Stream F))))) 162 | 163 | (define binary.test-byte 164 | -> (let A (binary.mkstream) 165 | . (binary.put-u8 0 A) 166 | A)) 167 | 168 | (define binary.test-put-vec 169 | -> (let A (binary.mkstream) 170 | V (bytevector 3) 171 | . (bytevector-u8-> V 0 3) 172 | . (bytevector-u8-> V 1 6) 173 | . (bytevector-u8-> V 2 9) 174 | . (binary.put-u8 10 A) 175 | . (binary.put-u8 15 A) 176 | . (output "A: ~A~%V: ~A~%" A V) 177 | . (binary.put-bytevector V A) 178 | (list<-bytevector (binary.bytevector-from-bytestream A)))) 179 | 180 | (define binary.test-put-stream 181 | -> (let A (binary.mkstream) 182 | B (binary.mkstream) 183 | . (binary.put-u8 10 A) 184 | . (binary.put-u8 15 A) 185 | . (binary.put-u8 7 B) 186 | . (output "A: ~A~%B: ~A~%" A B) 187 | . (binary.put-bytestream B A) 188 | (list<-bytevector (binary.bytevector-from-bytestream A)))) 189 | 190 | (define binary.test-write 191 | -> (let B (binary.mkstream) 192 | . (output "1~%") 193 | . (binary.put-u8 10 B) 194 | . (binary.put-u8 15 B) 195 | . (binary.put-u8 255 B) 196 | . (binary.put-u8 128 B) 197 | . (binary.put-u8 200 B) 198 | . (binary.put-u8 35 B) 199 | . (output "2~%") 200 | . (binary.put-u16 365 B) 201 | . (output "3~%") 202 | V (binary.bytevector-from-bytestream B) 203 | . (output "4~%") 204 | . (output "buf: ~A~%" (list<-bytevector V)) 205 | . (output "5~%") 206 | . (binary.bytestream-to-file "buf.bin" B) 207 | _)) 208 | -------------------------------------------------------------------------------- /calendar/calendar.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vasil-sd/shen-libs/6512ba4fad752158470a92766b55e30591eae12f/calendar/calendar.pdf -------------------------------------------------------------------------------- /calendar/calendar.shen: -------------------------------------------------------------------------------- 1 | \* Copyright (c) 2012, Mark Tarver 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 1. Redistributions of source code must retain the above copyright 7 | notice, this list of conditions and the following disclaimer. 8 | 2. Redistributions in binary form must reproduce the above copyright 9 | notice, this list of conditions and the following disclaimer in the 10 | documentation and/or other materials provided with the distribution. 11 | 3. All advertising materials mentioning features or use of this software 12 | must display the following acknowledgement: 13 | This product includes software developed by Mark Tarver. 14 | 4. Neither the name of the Mark Tarver nor the 15 | names of its contributors may be used to endorse or promote products 16 | derived from this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY ''AS IS'' AND ANY 19 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY 22 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 23 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 24 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 25 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 26 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 27 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *\ 28 | 29 | (package calendar [now internal-date unix gmt] 30 | 31 | (datatype globals 32 | 33 | _______________ 34 | (value *gmt*) : ((number --> number --> number) * number * number * number);) 35 | 36 | (define gmt 37 | {(number --> number --> number) --> number --> number --> number 38 | --> ((number --> number --> number) * number * number * number)} 39 | Plus/Minus Hours Minutes Seconds 40 | -> (set *gmt* (@p Plus/Minus Hours Minutes Seconds)) 41 | where (validate-gmt? Plus/Minus Hours Minutes Seconds) 42 | _ _ _ _ -> (error "error in GMT setting~%")) 43 | 44 | (define validate-gmt? 45 | {(number --> number --> number) --> number --> number --> number --> boolean} 46 | Plus/Minus Hours Minutes Seconds 47 | -> (cases (not (element? Plus/Minus [+ -])) false 48 | (not (and (integer? Hours) (integer? Minutes) (integer? Seconds))) false 49 | (= Hours 12) (and (= Minutes 0) (= Seconds 0)) 50 | (and (>= Hours 0) 51 | (<= Hours 11) 52 | (>= Minutes 0) 53 | (<= Minutes 59) 54 | (>= Seconds 0) 55 | (<= Seconds 59)) true 56 | true false)) 57 | 58 | (gmt + 0 0 0) 59 | 60 | (define now 61 | {number --> string} 62 | Days -> (internal-date->string (internal-date Days))) 63 | 64 | (define internal-date 65 | {number --> (list number)} 66 | Days -> (let UnixDate (+ (* 24 3600 Days) 67 | (get-time unix) 68 | (gmt-time (value *gmt*))) 69 | (if (> 0 UnixDate) 70 | (error "cannot regress date before 1970~%") 71 | (internal-date-h 72 | UnixDate 73 | (- 0 (* 24 3600)) 74 | 1970 75 | year 76 | []))) where (integer? Days) 77 | _ -> (error "internal-date requires an integer~%")) 78 | 79 | (define gmt-time 80 | {((number --> number --> number) * number * number * number) --> number} 81 | (@p Plus/Minus Hours Minutes Seconds) 82 | -> (Plus/Minus 0 (+ (* 3600 Hours) (* 60 Minutes) Seconds))) 83 | 84 | (define internal-date-h 85 | {number --> number --> number --> symbol --> (list number) --> (list number)} 86 | Now Now Count _ Date -> [Count | Date] 87 | Now Then Count Interval Date 88 | -> (let Then' (+ (seconds-in Count Interval Date) Then) 89 | (if (> Then' Now) 90 | (let NextInterval (next-interval Interval) 91 | Start (start-interval NextInterval) 92 | (internal-date-h Now Then Start NextInterval [Count | Date])) 93 | (internal-date-h Now Then' (+ Count 1) Interval Date)))) 94 | 95 | (define start-interval 96 | {symbol --> number} 97 | month -> 1 98 | day -> 1 99 | hour -> 0 100 | minute -> 0 101 | second -> 0) 102 | 103 | (define seconds-in 104 | {number --> symbol --> (list number) --> number} 105 | Count year _ -> (if (leap? Count) 106 | (* 366 24 3600) 107 | (* 365 24 3600)) 108 | 2 month [Year] -> (* 29 24 3600) where (leap? Year) 109 | Count month _ -> (* (days-in-month Count) 24 3600) 110 | _ day _ -> (* 24 3600) 111 | _ hour _ -> 3600 112 | _ minute _ -> 60 113 | _ second _ -> 1) 114 | 115 | (define next-interval 116 | {symbol --> symbol} 117 | year -> month 118 | month -> day 119 | day -> hour 120 | hour -> minute 121 | minute -> second) 122 | 123 | (define days-in-month 124 | {number --> number} 125 | 1 -> 31 126 | 2 -> 28 127 | 3 -> 31 128 | 4 -> 30 129 | 5 -> 31 130 | 6 -> 30 131 | 7 -> 31 132 | 8 -> 31 133 | 9 -> 31 134 | 10 -> 31 135 | 11 -> 30 136 | 12 -> 31) 137 | 138 | (define leap? 139 | {number --> boolean} 140 | Year -> (cases (integer? (/ Year 400)) true 141 | (integer? (/ Year 100)) false 142 | (integer? (/ Year 4)) true 143 | true false)) 144 | 145 | (define internal-date->string 146 | {(list number) --> string} 147 | [Seconds Minutes Hours Days Months Year] 148 | -> (make-string "~A:~A:~A, ~A~A ~A, ~A ~A" 149 | (pad Hours) (pad Minutes) (pad Seconds) 150 | Days (postfix-day Days) (month Months) Year (gmt-string (value *gmt*)))) 151 | 152 | (define gmt-string 153 | {((number --> number --> number) * number * number * number) --> string} 154 | (@p Plus/Minus Hours Minutes Seconds) 155 | -> (make-string "~AGMT ~A:~A:~A" 156 | Plus/Minus (pad Hours) (pad Minutes) (pad Seconds))) 157 | 158 | (define pad 159 | {number --> string} 160 | N -> (make-string "~A" N) where (> N 9) 161 | N -> (make-string "0~A" N)) 162 | 163 | (define postfix-day 164 | {number --> string} 165 | 1 -> "st" 166 | 21 -> "st" 167 | 31 -> "st" 168 | 2 -> "nd" 169 | 22 -> "nd" 170 | 3 -> "rd" 171 | 23 -> "rd" 172 | _ -> "th") 173 | 174 | (define month 175 | {number --> string} 176 | 1 -> "January" 177 | 2 -> "February" 178 | 3 -> "March" 179 | 4 -> "April" 180 | 5 -> "May" 181 | 6 -> "June" 182 | 7 -> "July" 183 | 8 -> "August" 184 | 9 -> "September" 185 | 10 -> "October" 186 | 11 -> "November" 187 | 12 -> "December")) -------------------------------------------------------------------------------- /calendar/module.shen: -------------------------------------------------------------------------------- 1 | (register-module [[name: calendar] 2 | [author: "Mark Tarver"] 3 | [load: "calendar.shen"]]) 4 | -------------------------------------------------------------------------------- /defstruct/defstruct.shen: -------------------------------------------------------------------------------- 1 | \* Copyright 2010-2011 Ramil Farkhshatov 2 | 3 | defstruct is free software: you can redistribute it and/or modify 4 | it under the terms of the GNU General Public License as published by 5 | the Free Software Foundation, either version 3 of the License, or 6 | (at your option) any later version. 7 | 8 | defstruct is distributed in the hope that it will be useful, 9 | but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | GNU General Public License for more details. 12 | 13 | You should have received a copy of the GNU General Public License 14 | along with defstruct. If not, see . 15 | 16 | Description 17 | =========== 18 | defstruct allows defining typed records stored for efficiency as vectors. 19 | 20 | The following example 21 | 22 | (defstruct person 23 | (name string) 24 | (last-name string) 25 | (gender symbol) 26 | (age number)) 27 | 28 | defines a constructor: 29 | 30 | mk-person : (string --> string --> symbol --> number --> person) 31 | 32 | setters: 33 | 34 | person-name-> : (person --> string --> person) 35 | person-last-name-> : (person --> string --> person) 36 | person-gender-> : (person --> symbol --> person) 37 | person-age-> : (person --> number --> person) 38 | 39 | accessors: 40 | 41 | person-name : (person --> string) 42 | person-last-name : (person --> string) 43 | person-gender : (person --> symbol) 44 | person-age: (person --> number) 45 | 46 | *\ 47 | 48 | (package defstruct [defstruct] 49 | 50 | (datatype struct-type 51 | X : symbol; Y : symbol; 52 | ======================= 53 | [X Y] : slot; 54 | 55 | X : slot; 56 | __________________ 57 | (head X) : symbol;) 58 | 59 | (define char-upcase 60 | {string --> string} 61 | "a" -> "A" 62 | "b" -> "B" 63 | "c" -> "C" 64 | "d" -> "D" 65 | "e" -> "E" 66 | "f" -> "F" 67 | "g" -> "G" 68 | "h" -> "H" 69 | "i" -> "I" 70 | "j" -> "J" 71 | "k" -> "K" 72 | "l" -> "L" 73 | "m" -> "M" 74 | "n" -> "N" 75 | "o" -> "O" 76 | "p" -> "P" 77 | "q" -> "Q" 78 | "r" -> "R" 79 | "s" -> "S" 80 | "t" -> "T" 81 | "u" -> "U" 82 | "v" -> "V" 83 | "w" -> "W" 84 | "x" -> "X" 85 | "y" -> "Y" 86 | "z" -> "Z" 87 | S -> S) 88 | 89 | (define string-capitalize 90 | {string --> string} 91 | (@s C S) -> (@s (char-upcase C) S) 92 | S -> S) 93 | 94 | (define sym-capitalize 95 | {symbol --> symbol} 96 | X -> (intern (string-capitalize (str X)))) 97 | 98 | (define slot-type 99 | Type I Stype Acc -> (let A (intern "A") 100 | B (intern "B") 101 | [A : Type; 102 | _______________________ 103 | [<-vector A I] : Stype; 104 | 105 | A : Type; B : Stype; 106 | _______________________ 107 | [vector-> A I B] : Type; 108 | | Acc])) 109 | 110 | (define slots-types 111 | _ [] _ Acc -> Acc 112 | Type [[Sname Stype] | Slots] N Acc -> 113 | (slots-types Type Slots (+ N 1) (slot-type Type N Stype Acc))) 114 | 115 | (define slots-defs 116 | {(list slot) --> (list symbol) --> (list symbol)} 117 | [] Acc -> Acc 118 | [[Name Type] | Slots] Acc -> (slots-defs 119 | Slots 120 | [(sym-capitalize Name) : Type; | Acc])) 121 | 122 | (define datatypes 123 | Type Slots -> (let Names (map (/. X (sym-capitalize (head X))) Slots) 124 | Defs (slots-defs Slots []) 125 | Types (slots-types Type Slots 1 []) 126 | (append [datatype Type] 127 | Defs 128 | [_________ 129 | (append [@v | Names] [[vector 0]]) : Type; 130 | | Types]))) 131 | 132 | (define accessors 133 | _ [] _ Acc -> Acc 134 | Type [[Sname Stype] | Slots] I Acc -> 135 | (accessors Type 136 | Slots 137 | (+ I 1) 138 | (let X (intern "X") 139 | N (intern (cn (str Type) (cn "-" (str Sname)))) 140 | [[define N 141 | { Type --> Stype } 142 | X -> [<-vector X I]] 143 | | Acc]))) 144 | 145 | (define setters 146 | _ [] _ Acc -> Acc 147 | Type [[Sname Stype] | Slots] I Acc -> 148 | (setters Type 149 | Slots 150 | (+ I 1) 151 | (let X (intern "X") 152 | Y (intern "Y") 153 | [[define (intern (cn (str Type) (cn "-" (cn (str Sname) "->")))) 154 | { Type --> Stype --> Type } 155 | X Y -> [vector-> X I Y]] 156 | | Acc]))) 157 | 158 | (define constructor-type 159 | Type [] Acc -> (reverse [} Type --> | Acc]) 160 | Type [[Sname Stype] | Slots] [] -> (constructor-type Type Slots [Stype {]) 161 | Type [[Sname Stype] | Slots] Acc -> 162 | (constructor-type Type Slots [Stype --> | Acc])) 163 | 164 | (define constr-init 165 | [] -> [vector 0] 166 | [N | Names] -> [@v N (constr-init Names)]) 167 | 168 | (define constructor 169 | Type Slots -> (let Types (constructor-type Type Slots []) 170 | Names (map (/. X (sym-capitalize (head X))) Slots) 171 | Init (constr-init Names) 172 | Constr (intern (cn "mk-" (str Type))) 173 | (append [define Constr] Types Names [-> Init]))) 174 | 175 | (define struct-aux 176 | Name Slots -> (error "Structure name must be a symbol.") 177 | where (not (symbol? Name)) 178 | Name [] -> (error "At least one slot must be defined in a structure.") 179 | Name Slots -> (append [(datatypes Name Slots) (constructor Name Slots)] 180 | (setters Name Slots 1 []) 181 | (accessors Name Slots 1 []))) 182 | 183 | (defmacro defstruct-macro 184 | [defstruct Name | Slots] -> [package null [] | (struct-aux Name Slots)])) 185 | -------------------------------------------------------------------------------- /defstruct/module.shen: -------------------------------------------------------------------------------- 1 | (register-module [[name: defstruct] 2 | [author: "Ramil Farkshatov"] 3 | [license: "GPLv3+"] 4 | [desc: "A macro for defining typed structures."] 5 | [load-fn: defstruct-load] 6 | [translate: "defstruct.shen"]]) 7 | 8 | (define defstruct-load 9 | {A --> boolean} 10 | _ -> (load/tc - "defstruct.shen")) 11 | -------------------------------------------------------------------------------- /dict/dict.shen: -------------------------------------------------------------------------------- 1 | \* dict.shen --- an ordered dictionary implementation 2 | 3 | Copyright (C) 2011, Eric Schulte 4 | 5 | *** License: 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions are 9 | met: 10 | 11 | - Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 14 | - Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | *** Commentary: 31 | 32 | (1-) (set *dict* (dict)) 33 | > 34 | 35 | (2-) (dict? (value *dict*)) 36 | true 37 | 38 | (3-) (dict-> (value *dict*) foo bar) 39 | bar 40 | 41 | (4-) (<-dict (value *dict*) foo) 42 | bar 43 | 44 | (5-) (dict-> (value *dict*) bar foo) 45 | foo 46 | 47 | (6-) (dict-> (value *dict*) bar baz) 48 | baz 49 | 50 | (7-) (contents (value *dict*)) 51 | [(@p foo bar) (@p bar baz)] 52 | 53 | (8-) (keys (value *dict*)) 54 | [foo bar] 55 | 56 | (9-) (vals (value *dict*)) 57 | [bar baz] 58 | 59 | *** Code: *\ 60 | (datatype dictionary 61 | Indexes : (list number); 62 | Store : (vector (list (@p A B))); 63 | ====================== 64 | (absvector symbol Keys Store) : dictionary;) 65 | 66 | (package dict- [dict? dict dict-> <-dict contents key? keys vals 67 | make-dict dictionary] 68 | 69 | (define dict? 70 | {A --> boolean} 71 | X -> (trap-error (= dictionary (<-address X 0)) (/. E false))) 72 | 73 | (define make-dict 74 | {number --> dictionary} 75 | N -> (let Dict (absvector 3) 76 | (do (address-> Dict 0 dictionary) 77 | (address-> Dict 1 []) 78 | (address-> Dict 2 (vector N)) 79 | Dict))) 80 | 81 | (defmacro dict-macro 82 | [dict] -> [make-dict 1024] 83 | [dict N] -> [make-dict N]) 84 | 85 | (define indexes 86 | {dictionary --> (list number)} 87 | X -> (<-address X 1)) 88 | 89 | (define store 90 | {dictionary --> (list (@p A B))} 91 | X -> (<-address X 2)) 92 | 93 | (define update-entry 94 | {A --> B --> (list (@p A B)) --> (list (@p A B))} 95 | Key Val [] -> [(@p Key Val)] 96 | Key Val [(@p Key _) | Entry] -> [(@p Key Val) | Entry] 97 | Key Val [Z | Entry] -> [Z | (update-entry Key Val Entry)]) 98 | 99 | (define dict-> 100 | {dictionary --> A --> B --> B} 101 | Dict Key Val -> 102 | (let Vector (store Dict) 103 | N (hash Key (limit Vector)) 104 | Entry (trap-error (<-vector Vector N) (/. E [])) 105 | (do (vector-> Vector N (update-entry Key Val Entry)) 106 | (vector-> Dict 1 (adjoin N (<-vector Dict 1))) 107 | Val))) 108 | 109 | (define tassoc 110 | \* Like `assoc' for lists of tuples. *\ 111 | _ [] -> (error "key not found~%") 112 | X [A|AS] -> (if (= X (fst A)) A (tassoc X AS))) 113 | 114 | (define <-dict 115 | {dictionary --> A --> B} 116 | Dict Key -> (let Vector (store Dict) 117 | Entry (trap-error (<-vector Vector (hash Key (limit Vector))) 118 | (/. E (error "key not found~%"))) 119 | (snd (tassoc Key Entry)))) 120 | 121 | (define contents 122 | {dictionary --> (list (@p A B))} 123 | Dict -> (contents- (reverse (indexes Dict)) (store Dict))) 124 | 125 | (define contents- 126 | {(list number) --> (vector (list (@p A B))) --> (list (@p A B))} 127 | [] _ -> [] 128 | [I|IS] Store -> (append (<-vector Store I) (contents- IS Store))) 129 | 130 | (define keys 131 | {dictionary --> (list A)} 132 | Dict -> (map (function fst) (contents Dict))) 133 | 134 | (define vals 135 | {dictionary --> (list B)} 136 | Dict -> (map (function snd) (contents Dict))) 137 | 138 | (define key? 139 | {dictionary --> A --> boolean} 140 | Dict Key -> (let Store (store Dict) 141 | (trap-error 142 | (do (tassoc Key (<-vector Store (hash Key (limit Store)))) 143 | true) 144 | (/. E false)))) 145 | 146 | ) 147 | -------------------------------------------------------------------------------- /ffi/ffi.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vasil-sd/shen-libs/6512ba4fad752158470a92766b55e30591eae12f/ffi/ffi.pdf -------------------------------------------------------------------------------- /ffi/ffi.shen: -------------------------------------------------------------------------------- 1 | (package ffi [ffi call-ffi] 2 | 3 | (define ffi 4 | Language OutSpec InSpec -> (push [Language OutSpec InSpec] *ffi*)) 5 | 6 | (define push 7 | X Y -> (set Y [X | (trap-error (value Y) (/. E []))])) 8 | 9 | (defmacro call-ffi-macro 10 | [call-ffi Foreign-Language Code] 11 | -> (let Spec (assoc Foreign-Language (value *ffi*)) 12 | (if (empty? Spec) 13 | (error "we don't know how to talk to ~A~%" Foreign-Language) 14 | (process-ffi-call Spec Code)))) 15 | 16 | (define process-ffi-call 17 | [_ (@p SyntaxOutF SendF) (@p SyntaxInF ReceiveF)] Code 18 | -> [SyntaxInF [ReceiveF [SendF [SyntaxOutF (quote Code)]]]]) 19 | 20 | (define quote 21 | [X | Y] -> [cons (quote X) (quote Y)] 22 | X -> X)) -------------------------------------------------------------------------------- /ffi/module.shen: -------------------------------------------------------------------------------- 1 | (register-module [[name: ffi] 2 | [author: "Mark Tarver"] 3 | [load: "ffi.shen"]]) 4 | -------------------------------------------------------------------------------- /file-system/file-system.shen: -------------------------------------------------------------------------------- 1 | \* file-system.shen --- cross-platform file system utilities 2 | 3 | Copyright (C) 2011, Eric Schulte 4 | 5 | *** License: 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions are 9 | met: 10 | 11 | - Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 14 | - Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | *** Commentary: 31 | 32 | The following functions are provided. 33 | 34 | return a path relative to a directory 35 | (join "file.ext" "directory") 36 | 37 | list the contents of a directory 38 | (dir-list "directory") 39 | 40 | does a file or directory exist at the given path 41 | (file-exists? "path") 42 | 43 | *** Code: *\ 44 | (package file-system- [file-exists? file-directory? split-paths join-paths 45 | directory-list directory-recur delete-file rename-file] 46 | 47 | (define starts-with 48 | "" _ -> true 49 | _ "" -> false 50 | (@s A AS) (@s B BS) -> (if (= A B) (starts-with AS BS) false)) 51 | 52 | (define length-str 53 | \* return the length of a string *\ 54 | {string --> number} 55 | "" -> 0 56 | (@s _ SS) -> (+ 1 (length-str SS))) 57 | 58 | (define mapcon 59 | \* like map but concatenate the results *\ 60 | {(A --> (list B)) --> (list A) --> (list B)} 61 | _ [] -> [] 62 | Fn [A|AS] -> (append (Fn A) (mapcon Fn AS))) 63 | 64 | (set *path-separator* 65 | \* ideally a new *operating-system* global variable could be used here *\ 66 | (cond 67 | ((starts-with "CLisp" (value *implementation*)) 68 | (cond 69 | ((let OS (SOFTWARE-TYPE) 70 | (or (starts-with "x86_64-linux-gnu-gcc" OS) 71 | (starts-with "x86_32-linux-gnu-gcc" OS))) 72 | "/") 73 | (true "/"))) 74 | (true "/"))) 75 | 76 | (define split-paths 77 | {string --> (list string)} 78 | Path -> (path-split- Path "" [])) 79 | 80 | (define path-split- 81 | "" Holder Acc -> (reverse (if (= Holder "") Acc [Holder|Acc])) 82 | (@s P Ps) Holder Acc -> 83 | (if (= (value *path-separator*) P) 84 | (path-split- Ps "" (if (= Holder "") Acc [Holder|Acc])) 85 | (path-split- Ps (@s Holder P) Acc))) 86 | 87 | (define file-exists? 88 | \* check if a file exists *\ 89 | {string --> boolean} 90 | Path -> (cond 91 | ((= "Common Lisp" (value *language*)) 92 | (if (= NIL (trap-error (PROBE-FILE Path) (/. E NIL))) 93 | false true)))) 94 | 95 | (define file-directory? 96 | \* check if a path is a directory *\ 97 | {string --> boolean} 98 | Path -> (cond 99 | ((starts-with "CLisp" (value *implementation*)) 100 | (if (= NIL (trap-error (PROBE-DIRECTORY Path) (/. E NIL))) 101 | false true)))) 102 | 103 | (define as-dir 104 | Path -> (if (= (value *path-separator*) (pos Path (- (length-str Path) 1))) 105 | Path 106 | (@s Path (value *path-separator*)))) 107 | 108 | (define join-paths 109 | \* return a path relative to a directory *\ 110 | {string --> string --> string} 111 | Dir Path -> (@s (as-dir Dir) Path)) 112 | 113 | (define directory-list 114 | {string --> [string]} 115 | Path -> (cond 116 | ((starts-with "CLisp" (value *implementation*)) 117 | (if (file-directory? Path) 118 | (map (lambda X (NAMESTRING X)) 119 | (append (DIRECTORY (@s Path "*/")) 120 | (DIRECTORY (MAKE-PATHNAME 121 | (INTERN "NAME" "KEYWORD") 122 | (INTERN "WILD" "KEYWORD") 123 | (INTERN "TYPE" "KEYWORD") 124 | (INTERN "WILD" "KEYWORD") 125 | (INTERN "DEFAULTS" "KEYWORD") Path)))) 126 | (error (make-string "~S does not name a directory" Path)))))) 127 | 128 | (define directory-recur 129 | \* call a function on every file within a directory *\ 130 | {(A --> B) --> String --> (list B)} 131 | Fn Path -> (cond 132 | ((file-exists? Path) [(Fn Path)]) 133 | ((file-directory? Path) 134 | (mapcon (directory-recur Fn) (directory-list Path))) 135 | (true []))) 136 | 137 | (define delete-file 138 | {string --> boolean} 139 | Path -> (cond 140 | ((= "Common Lisp" (value *language*)) 141 | (if (= NIL (trap-error (DELETE-FILE Path) (/. E []))) 142 | false true)))) 143 | 144 | (define rename-file 145 | {string --> boolean} 146 | From To -> (cond 147 | ((= "Common Lisp" (value *language*)) 148 | (trap-error (RENAME-FILE From To) (/. E false))))) 149 | 150 | (define read-string 151 | {(stream in)--> string} 152 | Stream -> (let Byte (read-byte Stream) 153 | (if (or (= Byte -1) (= Byte 10)) 154 | "" 155 | (cn (n->string Byte) (read-string-from-file Stream))))) 156 | 157 | \* read list of strings from stream *\ 158 | (define read-strings-from-stream 159 | {(stream in) --> (list string)} 160 | Stream -> (let Str (read-string-from-file Stream) 161 | (if (= Str "") 162 | [] 163 | [ Str | (read-text-stream Stream) ]))) 164 | 165 | \* read list of strings from file *\ 166 | (define read-text-file 167 | {string --> (list string)} 168 | Path -> (read-strings-from-stream (open file Path in))) 169 | 170 | 171 | ) 172 | -------------------------------------------------------------------------------- /for-expression/for-expression.shen: -------------------------------------------------------------------------------- 1 | \* for-expression.shen --- scala-like 'for expressions' for shen 2 | 3 | Copyright (C) 2013, Kjetil S. Matheussen 4 | 5 | *** License: 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions are 9 | met: 10 | 11 | - Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 14 | - Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | 31 | 32 | About: 33 | ====== 34 | 35 | 'for' is a macro that provides scala-like 'for expressions'. 36 | http://www.scala-lang.org/node/111 (also known as 'for comprehensions') 37 | 38 | 39 | 40 | Example 1: 41 | ========== 42 | 43 | The last element is returned. 44 | 45 | (for 1) 46 | 47 | => 1 48 | 49 | 50 | 51 | Example 2: 52 | ========== 53 | 54 | A generator. 55 | 56 | (for A <- [1 2] 57 | A) 58 | 59 | => [1 2] 60 | 61 | 62 | 63 | Example 3: 64 | ========== 65 | 66 | Two generators. 67 | 68 | (for A <- [1 2] 69 | B <- [a b] 70 | [A B]) 71 | 72 | => [[1 a] [1 b] [2 a] [2 b]] 73 | 74 | 75 | 76 | Example 4: 77 | ========== 78 | 79 | A guard. 80 | 81 | (for A <- [1 2] 82 | B <- [a b] 83 | if (= A 1) 84 | [A B]) 85 | => [[1 a] [1 b]] 86 | 87 | 88 | 89 | Example 5: 90 | ========== 91 | 92 | Similarly to example 4, this example uses 93 | two expressions and a guard. But 94 | by moving the guard one step up, the 95 | expression computes slightly more efficiently. 96 | The result is the same. 97 | 98 | (for A <- [1 2] 99 | if (= A 1) 100 | B <- [a b] 101 | [A B]) 102 | => [[1 a] [1 b]] 103 | 104 | 105 | 106 | 107 | Example 6: 108 | ========== 109 | 110 | Local variable 111 | 112 | (for A <- [1 2] 113 | B <- [a b] 114 | C = [A B] 115 | C) 116 | => [[1 a] [1 b] [2 a] [2 b]] 117 | 118 | 119 | Example 6: 120 | ========== 121 | 122 | Local variable with pattern matching 123 | 124 | (for A <- [1 2] 125 | B <- [a b] 126 | [C D] = [A B] 127 | C) 128 | => [1 1 2 2] 129 | 130 | 131 | Example 7: 132 | ========== 133 | 134 | Pattern matching. 135 | 136 | (for [A B] <- [[1 2][3 4]] 137 | (* A B)) 138 | => [2 12] 139 | 140 | 141 | Example 8: 142 | ========== 143 | 144 | Pattern matching with strings. 145 | (Pattern matching also works with tuples 146 | and vectors) 147 | 148 | (for (@s A B) <- ["ab" "cd" "de"] 149 | [A B]) 150 | => 151 | [["a" "b"] ["c" "d"] ["d" "e"]] 152 | 153 | *\ 154 | 155 | 156 | (load "../pattern-matching/pattern-matching.shen") 157 | 158 | 159 | (package for-expression [for create-pattern-matching-variables] 160 | 161 | 162 | (define create-for-expression 163 | [A] [] -> A 164 | [A] Empty -> [cons A Empty] 165 | [Matcher Arrow Value | As] Empty -> (let RecFunc (gensym (protect RecFunc)) 166 | Rest (gensym (protect Rest)) 167 | [let RecFunc [/. RecFunc Rest 168 | [if [empty? Rest] 169 | Empty 170 | (append [let] (create-pattern-matching-variables Matcher [head Rest]) 171 | [(create-for-expression As [RecFunc RecFunc [tail Rest]])])]] 172 | [RecFunc RecFunc Value]]) 173 | where (= Arrow <-) 174 | [Matcher Eq Value | As] Empty -> (append [let] (create-pattern-matching-variables Matcher Value) 175 | [(create-for-expression As Empty)]) 176 | where (= Eq =) 177 | [if Test | As] Empty -> [if Test 178 | (create-for-expression As Empty) 179 | Empty] 180 | As _ -> (do (print As) 181 | (print " - ") 182 | (error "for expression: syntax error"))) 183 | 184 | (defmacro for-macro 185 | [for | Rest] -> (create-for-expression Rest [])) 186 | 187 | ) 188 | -------------------------------------------------------------------------------- /for-expression/module.shen: -------------------------------------------------------------------------------- 1 | (register-module [[name: for-expression] 2 | [author: "Kjetil Matheussen"] 3 | [load: "for-expression.shen"]]) 4 | -------------------------------------------------------------------------------- /graph/generation.shen: -------------------------------------------------------------------------------- 1 | \* generation.shen --- functions for graph generation 2 | 3 | Copyright (C) 2011, Eric Schulte 4 | 5 | *** License: 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions are 9 | met: 10 | 11 | - Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 14 | - Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | *** Commentary: 31 | 32 | *** Code: *\ 33 | (load "./graph.shen") 34 | (load "../sequence/sequence.shen") 35 | (load "../macros/macros.shen") 36 | 37 | (define preferential-attachment 38 | {number --> number --> graph} 39 | N M -> (snd (reduce 40 | (/.* X (@p Ds (@p Vs Es)) -> 41 | (let Pnts (map (lambda X [X (pick Ds)]) (range 0 M)) 42 | (@p (append (flatten Pnts) Ds) 43 | (@p [X|Vs] (append Pnts Es))))) 44 | (@p [0] (@p [0] [])) (range 1 (- N 1))))) 45 | 46 | (define simple-preferential-attachment 47 | {number --> graph} 48 | N -> (preferential-attachment N 1)) 49 | 50 | (define erdos-reni 51 | {number --> number --> graph} 52 | N Prb -> (let Verts (range 0 N) 53 | Edges (lambda X (map (lambda Y 54 | (if (< (/ (random 100) 100) Prb) 55 | [X Y] [])) Verts)) 56 | (reduce (/.* X (@p Vs Es) -> (@p Vs (append (Edges X) Es))) 57 | (@p Verts []) (range 1 (- N 1))))) 58 | -------------------------------------------------------------------------------- /graph/graph.shen: -------------------------------------------------------------------------------- 1 | \* graph.shen --- a library for graph definition and manipulation 2 | 3 | Copyright (C) 2011, Eric Schulte 4 | 5 | *** License: 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions are 9 | met: 10 | 11 | - Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 14 | - Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | *** Commentary: 31 | 32 | Graphs are represented as two dictionaries one for vertices and one 33 | for edges. It is important to note that the dictionary implementation 34 | used is able to accept arbitrary data structures as keys. This 35 | structure technically encodes hypergraphs (a generalization of graphs 36 | in which each edge may contain any number of vertices). Examples of a 37 | regular graph G and a hypergraph H with the corresponding data 38 | structure are given below. 39 | 40 | 41 | --G=------------------------------------------------ 42 | Vertices Edges 43 | ---------- ------- 44 | +----Graph G-----+ hash | key -> value hash | key -> value 45 | | | -----+------>-------- -----+-------->--------- 46 | | a---b---c g | 1 | a -> [1] 1 | [a b] -> [1 2] 47 | | | | | 2 | b -> [1 2 3] 2 | [b c] -> [2 3] 48 | | d---e---f | 3 | c -> [2 4] 3 | [b d] -> [2 4] 49 | | | 4 | d -> [3 5] 4 | [c e] -> [3 5] 50 | +----------------+ 5 | e -> [4 5 6] 5 | [d e] -> [4 5] 51 | 6 | f -> [6] 6 | [e f] -> [5 6] 52 | 7 | g -> [] 53 | 54 | 55 | --H=------------------------------------------------ 56 | Vertices Edges 57 | ---------- ------- 58 | hash | key -> value hash | key -> value 59 | +-- Hypergraph H----+ -----+------>-------- -----+-------->--------- 60 | | | 1 | a -> [1] 1 | [a b [1 2 61 | | +------+ | 2 | b -> [1] | c d -> 3 4 62 | | +------+------+ | 3 | c -> [1] | e f] 5 6] 63 | | |a b c |d e f | | 4 | d -> [1 2] | 64 | | +------+------+ | 5 | e -> [1 2] 2 | [d e [4 5 65 | | |g h i | j | 6 | f -> [1 2] | f g -> 6 7 66 | | +------+ | 7 | g -> [2] | h i] 8 9] 67 | | | 8 | h -> [2] 68 | +-------------------+ 9 | i -> [2] 69 | 10 | j -> [] 70 | 71 | 72 | --G=-------Graph with associated edge/vertex data--------- 73 | Vertices Edges 74 | ---------- ------- 75 | +----Graph G-----+ hash | key -> value hash | key -> value 76 | | 4 6 7 | -----+------>-------- -----+-------->--------- 77 | |0a---b---c g | 1 | a -> (@p 0 [1]) 1 | [a b] -> (@p 4 [1 2]) 78 | | 1| 3| | 2 | b -> [1 2 3] 2 | [b c] -> (@p 6 [2 3]) 79 | | d---e---f | 3 | c -> [2 4] 3 | [b d] -> (@p 1 [2 4]) 80 | | 2 5 | 4 | d -> [3 5] 4 | [c e] -> (@p 3 [3 5]) 81 | +----------------+ 5 | e -> [4 5 6] 5 | [d e] -> (@p 2 [4 5]) 82 | 6 | f -> [6] 6 | [e f] -> (@p 5 [5 6]) 83 | 7 | g -> (@p 7 []) 84 | 85 | V = # of vertices 86 | E = # of edges 87 | M = # of vertex edge associations 88 | 89 | size = size of all vertices + all vertices stored in Vertices dict 90 | M * sizeof(int) * 4 + indices into Vertices & Edge dicts 91 | V * sizeof(dict entry) + storage in the Vertex dict 92 | E * sizeof(dict entry) + storage in the Edge dict 93 | 2 * sizeof(dict) the Vertices and Edge dicts 94 | 95 | *** Code: *\ 96 | (require dict) 97 | (require sequence) 98 | 99 | (datatype graph 100 | Vertices : dictionary; 101 | Edges : dictoinary; 102 | =================== 103 | (vector symbol Vertices Edges);) 104 | 105 | (package graph- [graph graph? vertices edges add-vertex 106 | add-edge has-edge? has-vertex? edges-for 107 | neighbors connected-to connected? connected-components 108 | vertex-partition bipartite? 109 | \* included from the sequence library\ *\ 110 | take drop take-while drop-while range flatten 111 | filter complement seperate zip indexed reduce 112 | mapcon partition partition-with unique frequencies 113 | shuffle pick remove-first interpose subset? 114 | cartesian-product 115 | \* included from the dict library\ *\ 116 | dict? dict dict-> <-dict contents key? keys vals 117 | dictionary make-dict] 118 | 119 | (define graph? 120 | X -> (= graph (<-address X 0))) 121 | 122 | (define make-graph 123 | \* create a graph with specified sizes for the vertex dict and edge dict *\ 124 | {number --> number --> graph} 125 | Vertsize Edgesize -> 126 | (let Graph (absvector 3) 127 | (do (address-> Graph 0 graph) 128 | (address-> Graph 1 (make-dict Vertsize)) 129 | (address-> Graph 2 (make-dict Edgesize)) 130 | Graph))) 131 | 132 | (defmacro graph-macro 133 | \* return a graph taking optional sizes for the vertex and edge dicts *\ 134 | [graph] -> [make-graph 1024 1024] 135 | [graph N] -> [make-graph N 1024] 136 | [graph N M] -> [make-graph N M]) 137 | 138 | (define vert-dict Graph -> (<-address Graph 1)) 139 | 140 | (define edge-dict Graph -> (<-address Graph 2)) 141 | 142 | (define vertices 143 | {graph --> (list A)} 144 | Graph -> (keys (vert-dict Graph))) 145 | 146 | (define edges 147 | {graph --> (list (list A))} 148 | Graph -> (keys (edge-dict Graph))) 149 | 150 | (define get-data 151 | Value V -> (if (tuple? Value) 152 | (fst Value) 153 | (error (make-string "no data for ~S~%" V)))) 154 | 155 | (define vertex-data 156 | Graph V -> (get-data (<-dict (vert-dict Graph) V) V)) 157 | 158 | (define edge-data 159 | Graph V -> (get-data (<-dict (edge-dict Graph) V) V)) 160 | 161 | (define resolve 162 | {(vector (list A)) --> (@p number number) --> A} 163 | Vector (@p Index Place) -> (nth (+ 1 Place) (<-vector Vector Index))) 164 | 165 | (define resolve-vert 166 | {graph --> (@p number number) --> A} 167 | Graph Place -> (resolve (<-address (vert-dict Graph) 2) Place)) 168 | 169 | (define resolve-edge 170 | {graph --> (@p number number) --> A} 171 | Graph Place -> (resolve (<-address (edge-dict Graph) 2) Place)) 172 | 173 | (define edges-for 174 | {graph --> A --> (list (list A))} 175 | Graph Vert -> (let Val (trap-error (<-dict (vert-dict Graph) Vert) (/. E [])) 176 | Edges (if (tuple? Val) (snd Val) Val) 177 | (map (lambda X (fst (resolve-edge Graph X))) Val))) 178 | 179 | (define add-vertex-w-data 180 | \* add a vertex to a graph *\ 181 | {graph --> A --> B --> A} 182 | G V Data -> (do (dict-> (vert-dict G) V (@p Data (edges-for G V))) V)) 183 | 184 | (define add-vertex-w/o-data 185 | \* add a vertex to a graph *\ 186 | {graph --> A --> B --> A} 187 | G V -> (do (dict-> (vert-dict G) V (edges-for G V)) V)) 188 | 189 | (defmacro add-vertex-macro 190 | [add-vertex G V] -> [add-vertex-w/o-data G V] 191 | [add-vertex G V D] -> [add-vertex-w-data G V D]) 192 | 193 | (define update-vert 194 | \* in a dict, add an edge to a vertex's edge list *\ 195 | {vector --> (@p number number) --> A --> number} 196 | Vs Edge V -> (let Store (<-address Vs 2) 197 | N (hash V (limit Store)) 198 | VertLst (trap-error (<-vector Store N) (/. E [])) 199 | Contents (trap-error (<-dict Vs V) (/. E [])) 200 | (do (dict-> Vs V (if (tuple? Contents) 201 | (@p (fst Contents) 202 | (adjoin Edge (snd Contents))) 203 | (adjoin Edge Contents))) 204 | (@p N (length VertLst))))) 205 | 206 | (define update-edges-vertices 207 | \* add an edge to a graph *\ 208 | {graph --> (list A) --> (list A)} 209 | Graph Edge -> 210 | (let Store (<-address (edge-dict Graph) 2) 211 | EdgeID (hash Edge (limit Store)) 212 | EdgeLst (trap-error (<-vector Store EdgeID) (/. E [])) 213 | (map (update-vert (vert-dict Graph) (@p EdgeID (length EdgeLst))) Edge))) 214 | 215 | (define add-edge-w-data 216 | G E D -> (do (dict-> (edge-dict G) E (@p D (update-edges-vertices G E))) E)) 217 | 218 | (define add-edge-w/o-data 219 | G E -> (do (dict-> (edge-dict G) E (update-edges-vertices G E)) E)) 220 | 221 | (defmacro add-edge-macro 222 | [add-edge G E] -> [add-edge-w/o-data G E] 223 | [add-edge G E V] -> [add-edge-w-data G E V]) 224 | 225 | (define has-edge? 226 | {graph --> (list A) --> boolean} 227 | Graph Edge -> (key? (edge-dict Graph) Edge)) 228 | 229 | (define has-vertex? 230 | {graph --> A --> boolean} 231 | Graph Vertex -> (key? (vert-dict Graph) Vertex)) 232 | 233 | (define neighbors 234 | \* Return the neighbors of a vertex *\ 235 | {graph --> A --> (list A)} 236 | Graph Vert -> (unique (mapcon (remove-first Vert) (edges-for Graph Vert)))) 237 | 238 | (define connected-to- 239 | {graph --> (list A) --> (list A) --> (list A)} 240 | Graph [] Already -> Already 241 | Graph New Already -> 242 | (let Reachable (unique (mapcon (neighbors Graph) New)) 243 | New (difference Reachable Already) 244 | (connected-to- Graph New (append New Already)))) 245 | 246 | (define connected-to 247 | \* return all vertices connected to the given vertex, including itself *\ 248 | {graph --> A --> (list A)} 249 | Graph V -> (connected-to- Graph [V] [V])) 250 | 251 | (define connected? 252 | \* return if a graph is fully connected *\ 253 | {graph --> boolean} 254 | Graph -> (reduce (/. V Acc 255 | (and Acc 256 | (subset? (vertices Graph) (connected-to Graph V)))) 257 | true (vertices Graph))) 258 | 259 | (define connected-components- 260 | \* given a graph return a list of connected components *\ 261 | {graph --> (list A) --> (list (list A)) --> (list graph)} 262 | Graph [] _ -> [] 263 | Graph VS [] -> (map (/. V (let Component (graph 1 0) 264 | (do (add-vertex Component V) Component))) 265 | VS) 266 | Graph [V|VS] ES -> 267 | (let Con-verts (connected-to Graph V) 268 | Con-edges (filter (/. E (subset? E Con-verts)) ES) 269 | Component (graph (length Con-verts) (length Con-edges)) 270 | (do (map (add-edge-w/o-data Component) Con-edges) 271 | (cons Component (connected-components- Graph 272 | (difference VS Con-verts) 273 | (difference ES Con-edges)))))) 274 | 275 | (define connected-components 276 | {graph --> (list graph)} 277 | Graph -> (connected-components- Graph (vertices Graph) (edges Graph))) 278 | 279 | (define place-vertex 280 | \* given a graph, vertex and list of partitions, partition the vertex *\ 281 | {graph --> A --> (list (list A)) --> (list (list A))} 282 | Graph V [] -> (if (element? V (neighbors Graph V)) 283 | (simple-error 284 | (make-string "self-loop ~S, no vertex partition" V)) 285 | [[V]]) 286 | Graph V [C|CS] -> (let Neighbors (neighbors Graph V) 287 | (if (element? V Neighbors) 288 | (simple-error 289 | (make-string "self-loop ~S, no vertex partition" V)) 290 | (if (empty? (intersection C Neighbors)) 291 | [[V|C]|CS] 292 | [C|(place-vertex Graph V CS)])))) 293 | 294 | (define vertex-partition 295 | \* partition the vertices of a graph *\ 296 | {graph --> (list (list A))} 297 | Graph -> (reduce (place-vertex Graph) [] (vertices Graph))) 298 | 299 | (define bipartite? 300 | \* check if a graph is bipartite *\ 301 | {graph --> boolean} 302 | Graph -> (= 2 (length (vertex-partition Graph)))) 303 | 304 | ) 305 | 306 | \* simple tests 307 | 308 | (set g (graph)) 309 | (add-edge (value g) [chris patton]) 310 | (add-edge (value g) [eric chris]) 311 | (add-vertex (value g) nobody) 312 | (has-edge? (value g) [patton chris]) 313 | (edges-for (value g) chris) 314 | (neighbors (value g) chris) 315 | (neighbors (value g) nobody) 316 | (connected-to (value g) chris) 317 | (connected? (value g)) 318 | (connected-components (value g)) <- fail when package wrapper is used 319 | (map (function vertices) (connected-components (value g))) 320 | 321 | *\ 322 | -------------------------------------------------------------------------------- /graph/randon-geometric-graph.shen: -------------------------------------------------------------------------------- 1 | \* randon-geometric-graph.shen --- generation and manipulation of RGGs 2 | 3 | Copyright (C) 2011, Eric Schulte 4 | 5 | *** License: 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions are 9 | met: 10 | 11 | - Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 14 | - Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | *** Commentary: 31 | 32 | See M. Penrose _Random Geometric Graphs_, Oxford Studies in Probability 33 | for more information on RGGs. 34 | 35 | *** Code: *\ 36 | -------------------------------------------------------------------------------- /html/html.shen: -------------------------------------------------------------------------------- 1 | \* html.shen --- html generation functions for shen 2 | 3 | Copyright (C) 2011, Eric Schulte 4 | 5 | *** License: 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions are 9 | met: 10 | 11 | - Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 14 | - Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | *** Commentary: 31 | 32 | The standard lisp-to-html conversion tool suite. Follows some of 33 | the convertions of Clojure's hiccup. 34 | 35 | an example... 36 | 37 | (8-) (html [ul#todo1.tasks.stuff [: [title "today"]] 38 | (map (lambda Str [li Str]) ["get milk" "dishes"])]) 39 | "
    40 |
  • get milk
  • dishes
" 41 | 42 | *** Code: *\ 43 | (trap-error 44 | (require string) 45 | (/. E (load "../string/string.shen"))) 46 | 47 | (package string- [html 48 | \* symbols included from string *\ 49 | takestr dropstr substr length-str index-str 50 | reverse-str starts-with substr? replace-str 51 | join split trim-left trim-right chomp trim] 52 | 53 | (define to-str 54 | \* return argument as a string, if already a string do not change *\ 55 | X -> X where (string? X) 56 | X -> (str X)) 57 | 58 | (define gassoc 59 | X Y -> (hd (tl (assoc X Y)))) 60 | 61 | (define dassoc 62 | X Y -> (remove (assoc X Y) Y)) 63 | 64 | (define passoc 65 | [] Y -> Y 66 | [X XV] Y -> (let Orig (gassoc X Y) 67 | New (if (cons? Orig) [XV|Orig] XV) 68 | [[X New]|(dassoc X Y)])) 69 | 70 | (define html 71 | X -> X where (string? X) 72 | [Tag [: |Attrs] |Body] -> 73 | (let Tag-comps (css-parse-symbol Tag) 74 | Tag (gassoc tag Tag-comps) 75 | New-attrs (passoc (assoc class Tag-comps) 76 | (passoc (assoc id Tag-comps) Attrs)) 77 | (@s (make-string "<~S" Tag) (attributes New-attrs) ">" 78 | (html Body) 79 | (make-string "" Tag))) where (symbol? Tag) 80 | [Tag|Body] -> (html [Tag [:] Body]) where (symbol? Tag) 81 | [H|HS] -> (@s (html H) (html HS)) 82 | [] -> "") 83 | 84 | (define css-parse-symbol 85 | {symbol --> [[symbol A]]} 86 | Symbol -> (let String (str Symbol) 87 | Class-split (split (str .) String) 88 | Class (map (function intern) (tl Class-split)) 89 | Id-split (split (str #) (hd Class-split)) 90 | Tag (hd Id-split) 91 | Id (tl Id-split) 92 | ((if (= [] Id) (/. X X) (cons [id (intern (hd Id))])) 93 | ((if (= [] Class) (/. X X) (cons [class Class])) 94 | [[tag (intern Tag)]])))) 95 | 96 | (define attributes 97 | [] -> "" 98 | [[K V]|AS] -> (@s " " (to-str K) "='" 99 | (if (cons? V) (join " " (map (function str) V)) (to-str V)) 100 | "'" (attributes AS))) 101 | 102 | ) 103 | -------------------------------------------------------------------------------- /macros/macros.shen: -------------------------------------------------------------------------------- 1 | \* macros.shen --- collection of simple macros for various purposes 2 | 3 | Copyright (C) 2011, Eric Schulte 4 | 5 | *** License: 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions are 9 | met: 10 | 11 | - Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 14 | - Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | *** Commentary: 31 | 32 | *** Code: *\ 33 | (trap-error 34 | (do (require string) 35 | (require sequence)) 36 | (/. E 37 | (do (load "../string/string.shen") 38 | (load "../sequence/sequence.shen")))) 39 | 40 | \*** Documentation Strings ***\ 41 | (defmacro def-macro 42 | \* function definition with documentation strings *\ 43 | [def Name Docstring | Body] -> 44 | [package null [] 45 | [set *functions* 46 | [adjoin [@p Name Docstring] 47 | [trap-error [value *functions*] 48 | [/. _ [set *functions* []]]]]] 49 | [define | [Name | Body]]]) 50 | 51 | (define apropos 52 | {string --> [(@p symbol string)]} 53 | \* Return a list of functions matching a search term *\ 54 | Str -> (filter (/. Pair (or (substr? Str (make-string "~S" (fst Pair))) 55 | (substr? Str (snd Pair)))) 56 | (value *functions*))) 57 | 58 | (define tassoc 59 | \* Like `assoc' for lists of tuples. *\ 60 | _ [] -> [] 61 | X [A|AS] -> (if (= X (fst A)) A (tassoc X AS))) 62 | 63 | (define documentation 64 | \* Return the documentation string for a function *\ 65 | Func -> (let Doc (tassoc Func (value *functions*)) 66 | (if (tuple? Doc) 67 | (snd Doc) 68 | (make-string "Documentation for `~S' not found" Func)))) 69 | 70 | \*** Pattern matching in anonymous lambdas ***\ 71 | (defmacro l-macro 72 | \* Thanks to vasil from the Qi-lang mailing list for this function definition *\ 73 | [/.* | PatternsActions] -> 74 | (let TmpName (intern (str (gensym tmpname))) 75 | DBody (tl (tl (compile (/. X (shen. X)) [ TmpName | PatternsActions]))) 76 | [/. | (append (hd DBody) (tl DBody))])) 77 | 78 | \* For extended comments in source code *\ 79 | (defmacro comment-macro 80 | [comment | _] -> [] 81 | [comment _] -> []) 82 | -------------------------------------------------------------------------------- /maths/Maths Library.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vasil-sd/shen-libs/6512ba4fad752158470a92766b55e30591eae12f/maths/Maths Library.pdf -------------------------------------------------------------------------------- /maths/macro-def.shen: -------------------------------------------------------------------------------- 1 | \* Copyright (c) 03-12-12, Willi O Riha 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright notice, 10 | this list of conditions and the following disclaimer in the documentation 11 | and/or other materials provided with the distribution. 12 | 13 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 14 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 15 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 16 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 17 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 18 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 19 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 20 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 21 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 22 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | *\ 24 | 25 | (defmacro let-macro 26 | [let [@p X Y] Z | W] 27 | -> (let Var (gensym (protect V)) 28 | [let Var Z | (subst [snd Var] Y (subst [fst Var] X W))]) 29 | [let [X | Y] Z W] 30 | -> (let Z' (gensym (protect V)) \* changed 29-09-12 *\ 31 | Z' Z 32 | (recursive-let-list 1 [X | Y] Z' W))) 33 | 34 | (define recursive-let-list 35 | _ [] _ W -> W 36 | N [cons V Vs] Z' W -> [let V [nth N Z'] (recursive-let-list (+ N 1) Vs Z' W)]) 37 | 38 | (defmacro trap-macro 39 | [t'rap Exp Str] -> [trap-error Exp [/. (protect E) [error [@s [error-to-string (protect E)] Str]]]]) 40 | 41 | (defmacro max-macro 42 | [max X] -> X 43 | [max W X Y | Z] -> [max W [max X Y | Z]]) 44 | 45 | (defmacro min-macro 46 | [min X] -> X 47 | [min W X Y | Z] -> [min W [min X Y | Z]]) 48 | 49 | (defmacro gcd-macro 50 | [gcd X] -> [abs X] 51 | [gcd W X Y | Z] -> [gcd W [gcd X Y | Z]]) 52 | 53 | (defmacro lcm-macro 54 | [lcm X] -> [abs X] 55 | [lcm W X Y | Z] -> [lcm W [lcm X Y | Z]]) 56 | 57 | (defmacro round-macro 58 | [round N] -> [maths-round0 N] 59 | [round N1 N2] -> [maths-round' N1 N2]) 60 | 61 | (declare sqrt [number --> number]) 62 | 63 | (defmacro string->int-macro 64 | [string->int Str] -> [string-oct-hex-dec->decimal Str] 65 | [string->int Str B] -> [radixB->decimal Str B]) 66 | -------------------------------------------------------------------------------- /maths/maths-functions.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vasil-sd/shen-libs/6512ba4fad752158470a92766b55e30591eae12f/maths/maths-functions.pdf -------------------------------------------------------------------------------- /maths/maths-lib.shen: -------------------------------------------------------------------------------- 1 | \* Copyright (c) 03-12-12, Willi O Riha 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright notice, 10 | this list of conditions and the following disclaimer in the documentation 11 | and/or other materials provided with the distribution. 12 | 13 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 14 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 15 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 16 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 17 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 18 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 19 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 20 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 21 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 22 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | *\ 24 | \* changed export list *\ 25 | (package maths [!= even? odd? natural? positive? negative? zero? 26 | divisible-by? prime? /mod /rem /% 27 | div trunc-div div-eucl mod rem % 28 | gcd lcm max min sign abs ceiling floor trunc fmod 29 | maths-round0 maths-round' 30 | int-part frac-part modf frexp ldexp 31 | sin cos tan asin acos atan atan2 32 | square power exp sinh cosh tanh 33 | dms->degs degs->dms rad->degs degs->rad 34 | expt sqrt log log2 log10 log' 35 | pi pi/2 pi/4 pi*2 log2 e log2e log10e 36 | one/pi two/pi two/sqrt-pi sqrt2 one/sqrt2] 37 | 38 | (define sign 39 | { number --> number } 40 | X -> 1 where (> X 0) 41 | X -> -1 where (< X 0) 42 | _ -> 0) 43 | 44 | (define abs 45 | { number --> number } 46 | X -> (if (>= X 0) X (- 0 X))) 47 | 48 | \* ====================================================== *\ 49 | 50 | (define floor 51 | { number --> number } 52 | X -> (if (>= X 0) (floor-pos X) (floor-neg X))) 53 | 54 | (define floor-pos 55 | { number --> number } 56 | X -> 0 where (< X 1) \* not really necesary *\ 57 | X -> (floor-h X (pow-2 1 X) 0)) 58 | 59 | (define floor-neg 60 | { number --> number } 61 | X -> (let F (floor-pos (- 0 X)) 62 | F1 (- 0 F) 63 | (if (= F1 X) F1 (- F1 1)))) 64 | 65 | (define floor-h 66 | { number --> number --> number --> number } 67 | \* X P Q -> Q where (< P 1) *\ 68 | X 1 Q -> (if (<= 1 X) (+ Q 1) Q) 69 | X P Q -> (if (<= P X) 70 | (floor-h (- X P) (rsh P) (+ Q P)) 71 | (floor-h X (rsh P) Q))) 72 | 73 | (define ceiling 74 | { number --> number } 75 | X -> (- 0 (floor (- 0 X)))) 76 | 77 | (define trunc \* same as int-part *\ 78 | { number --> number } 79 | X -> (let FloorAbsX (floor-pos(abs X)) 80 | (if (>= X 0) FloorAbsX (- 0 FloorAbsX)))) 81 | 82 | \* ====================================================== *\ 83 | 84 | (define maths-round0 85 | { number --> number } 86 | X -> (if (round-down? X) (floor X) (ceiling X))) 87 | 88 | (define round-down? 89 | { number --> boolean } 90 | X -> (let FLX (floor X) 91 | FRX (- X FLX) 92 | (or(< FRX 0.5) (and (= FRX 0.5) (even? FLX))))) 93 | 94 | (define int-part \* same as trunc *\ 95 | { number --> number } 96 | X -> (if (>= X 0) (floor X) (ceiling X))) 97 | 98 | (define frac-part 99 | { number --> number } 100 | X -> (- X (int-part X))) 101 | 102 | (define modf 103 | { number --> (number * number) } 104 | X -> (let Int (int-part X) 105 | (@p Int (- X Int)))) 106 | 107 | (define maths-round' 108 | { number --> number --> number } 109 | X N -> (let Scale (power 10 N) 110 | (/ (maths-round0 (* X Scale)) Scale))) 111 | 112 | \* auxiliary fn: 113 | precond: P > 0, X > 0. (if P <= 0 -> infinite loop!) 114 | usual call: (pow-2 1 X) which returns 115 | the largest power of 2 not greater than X *\ 116 | (define pow-2 117 | { number --> number --> number } 118 | P X -> (let P2 (* P 2) 119 | (if (<= P2 X) (pow-2 P2 X) P))) 120 | 121 | \* floating modulus - similar to rem *\ 122 | (define fmod 123 | { number --> number --> number } 124 | X Y -> (let YA (abs Y) 125 | Q (/ X YA) 126 | (if (> X 0) (- X (* (floor Q) YA)) 127 | (- X (* (ceiling Q) YA))))) 128 | \* ====================================================== *\ 129 | (define frexp 130 | { number --> (number * number) } 131 | 0 -> (@p 0 0) 132 | X -> (if (> X 0) (frexp-pos X) (frexp-neg X))) 133 | 134 | (define frexp-neg 135 | { number --> (number * number) } 136 | X -> (let Tmp (frexp-pos (- 0 X)) 137 | (@p (- 0 (fst Tmp)) (snd Tmp)))) 138 | 139 | (define frexp-pos 140 | { number --> (number * number) } 141 | X -> (if (> X 0.5) (div-2 X 0) (mult-2 X 0))) 142 | 143 | (define mult-2 \* (0 X) -> (1 2*X) -> ... -> (Exp Y), where Y >= 0.5 *\ 144 | { number --> number --> (number * number) } 145 | X Exp -> (if (< X 0.5) (mult-2 (* X 2)(- Exp 1)) (@p X Exp))) 146 | 147 | (define div-2 \* (0 X) -> (1 X/2) -> ... -> (Exp Y), where Y < 1 *\ 148 | { number --> number --> (number * number) } \* corrected >= *\ 149 | X Exp -> (if (>= X 1.0) (div-2 (/ X 2)(+ Exp 1)) (@p X Exp))) 150 | 151 | (define ldexp 152 | { number --> number --> number } 153 | X Exp -> (* X (power 2 Exp))) 154 | \* ====================================================== *\ 155 | 156 | (define square 157 | { number --> number } 158 | X -> (* X X) ) 159 | 160 | (define power-pos 161 | { number --> number --> number } 162 | X 1 -> X 163 | X N -> (let Y (square (power-pos X (rsh N))) 164 | (if (even? N) Y (* X Y)))) 165 | 166 | (define power \* fast integer power *\ 167 | { number --> number --> number } 168 | X 0 -> 1 169 | X N -> (error "power - exponent must be an integer~%") where (not (integer? N)) 170 | X N -> (let P (power-pos X (abs N)) 171 | (if (> N 0) P (/ 1.0 P)))) 172 | \* ====================================================== *\ 173 | (datatype global 174 | if (element? Global [tolerance e log2e log10e log2 log10 pi pi/2 pi/4 pi*2 175 | pi/180 l80/pi one/pi two/pi two/sqrt-pi sqrt2 one/sqrt2]) 176 | ________________ 177 | (value Global) : number; ) 178 | 179 | \* this constant may be changed - it works for double precision ! *\ 180 | (set tolerance 1e-15) 181 | \* used *\ 182 | (set e 2.71828182845904523536) 183 | (set log10 2.30258509299404568402) 184 | (set log2 0.69314718055994530942) 185 | (set pi 3.14159265358979323846) 186 | (set pi/2 1.57079632679489661923) 187 | (set pi/4 0.78539816339744830962) 188 | (set pi*2 6.28318530717958647692) 189 | \* not used *\ 190 | (set one/pi 0.31830988618379067154) 191 | (set two/pi 0.63661977236758134308) 192 | (set log2e 1.44269504088896340736) 193 | (set log10e 0.43429448190325182765) 194 | (set sqrt2 1.41421356237309504880) 195 | (set one/sqrt2 0.70710678118654752440) 196 | (set two/sqrt-pi 1.12837916709551257390) 197 | \* conversion constants *\ 198 | (set pi/180 0.017453292519943295769) \* 1 degree in radians *\ 199 | (set l80/pi 57.295779513082320876798) \* 1 radian in degrees *\ 200 | 201 | (define small-enough? 202 | { number --> boolean } 203 | X -> (< (abs X) (value tolerance))) 204 | 205 | \*====================================================== *\ 206 | 207 | (define rad->degs \* radians -> degrees *\ 208 | {number --> number } 209 | X -> (* X (value l80/pi))) 210 | 211 | (define degs->rad \* degrees -> radians *\ 212 | { number --> number } 213 | X -> (* X (value pi/180))) 214 | 215 | (define dms->degs \* [degs mins secs] -> degrees *\ 216 | {(list number) --> number } 217 | [] -> (error "dms->degs - no arguments given!") 218 | [_ _ _ _ | _] -> (error "too many arguments in dms->degs") 219 | [Degs | Y] -> (let Tmp (dms->degs-pos [(abs Degs) | Y]) 220 | (if (negative? Degs ) (- 0 Tmp) Tmp))) 221 | 222 | (define dms->degs-pos \* [degs mins secs] -> degrees where degs >= 0 *\ 223 | {(list number) --> number } 224 | [Degs] -> Degs 225 | [Degs | _] -> (error "dms->degs - type error in Degs") where (not (integer? Degs)) 226 | [Degs Mins] -> (+ Degs (/ Mins 60)) where (range-ok? Mins) 227 | [Degs Mins _] -> (error "dms->degs - type error in Mins") where (not (integer? Mins)) 228 | [Degs Mins Secs] -> (+ Degs (/(+ Mins (/ Secs 60)) 60)) where (and (range-ok? Mins)(range-ok? Secs)) 229 | X -> (error "dms->degs - range error in Mins/Secs")) 230 | 231 | (define degs->dms \* degrees -> [degs mins secs] *\ 232 | { number --> (list number) } 233 | X -> (let Degs (trunc X) 234 | Tmp (abs (* (- X Degs) 60)) 235 | Mins (floor Tmp) 236 | Secs (* (- Tmp Mins) 60) 237 | [Degs Mins (maths-round' Secs 10)])) \* added 14-12-11 *\ 238 | 239 | (define range-ok? \* auxiliary *\ 240 | { number --> boolean } 241 | M -> (and (>= M 0)(< M 60))) 242 | \*====================================================== *\ 243 | 244 | (define exp 245 | { number --> number } 246 | X -> (let X1 (ceiling X) 247 | X2 (- X X1) 248 | (if (< X2 -0.5) 249 | (/ 1.0 (exp (- 0 X))) 250 | (exp-large X)))) 251 | 252 | (define exp-large 253 | { number --> number } 254 | X -> (let X1 (ceiling X) 255 | P (power (value e) X1) 256 | (* P (exp-h (- X X1))))) 257 | 258 | (define exp-h 259 | { number --> number } 260 | X -> (exp-sum 1 1.0 1.0 X)) 261 | 262 | (define exp-sum 263 | { number --> number --> number --> number --> number } 264 | I P Sum X -> Sum where (small-enough? P) 265 | I P Sum X -> (let NewP (/ (* P X) I) 266 | (exp-sum (+ I 1) NewP (+ Sum NewP) X))) 267 | 268 | (define sinh 269 | { number --> number } 270 | X -> (let ExpX (exp X) 271 | (/ (- ExpX (/ 1 ExpX)) 2))) 272 | 273 | (define cosh 274 | { number --> number } 275 | X -> (let ExpX (exp X) 276 | (/ (+ ExpX (/ 1 ExpX)) 2))) 277 | 278 | (define tanh 279 | { number --> number } 280 | X -> (sign X) where (> (abs X) 20) 281 | X -> (let Exp2X (exp (+ X X)) 282 | (/ (- Exp2X 1) (+ Exp2X 1)))) 283 | \*====================================================== *\ 284 | 285 | (define expt 286 | { number --> number --> number } 287 | 0 0 -> 1 288 | 0 Y -> (error "expt undefined!~%") where (< Y 0) 289 | X Y -> (error "expt undefined!~%") where (and (not (integer? Y))(< X 0)) 290 | X Y -> (power X Y) where (integer? Y) 291 | X Y -> (exp (* Y (log X)))) 292 | \*====================================================== *\ 293 | 294 | (define sqrt 295 | { number --> number } 296 | X -> (error "sqrt(x) for x < 0!~%") where (< X 0) 297 | X -> (sqrt-scale X 1)) 298 | 299 | (define sqrt-scale 300 | { number --> number --> number } 301 | X F -> (* (sqrt-h X) F) where (< X 1) 302 | X F -> (sqrt-scale (/ X 100) (* F 10))) 303 | 304 | (define sqrt-h 305 | { number --> number } 306 | X -> (sqrt-iter X (/ X 2) X)) 307 | 308 | (define sqrt-iter 309 | { number --> number --> number --> number} 310 | X0 X A -> X where (small-enough? (- X X0)) 311 | X0 X A -> (sqrt-iter X (mean A X0) A)) 312 | 313 | (define mean 314 | { number --> number --> number } 315 | X Y -> (/ (+ Y (/ X Y)) 2)) 316 | \* =====================================================*\ 317 | 318 | (define log 319 | { number --> number } 320 | X -> (error "log(x) for x < 0!~%") where (<= X 0) 321 | X -> (let Sgn (if (< X 0.5) -1 1) 322 | X1 (if (< X 0.5) (/ 1 X) X) 323 | (* (log-scale X1 0) Sgn))) 324 | 325 | (define log-scale 326 | { number --> number --> number } 327 | A K -> (+ (log-h A) K) where (< A 1) 328 | A K -> (log-scale (/ A (value e)) (+ K 1))) 329 | 330 | (define log-h 331 | { number --> number } 332 | X -> (let X1 (/ (- X 1) (+ X 1)) 333 | X2 (* X1 X1) 334 | (log-sum 3 X1 X1 X2))) 335 | 336 | (define log-sum 337 | { number --> number --> number --> number --> number } 338 | I P Sum X2 -> (* Sum 2) where (small-enough? P) 339 | I P Sum X2 -> (let Ptmp (* P X2) 340 | (log-sum (+ I 2) Ptmp (+ Sum (/ Ptmp I)) X2))) 341 | 342 | (define log10 343 | { number --> number } 344 | X -> (/ (log X) (value log10))) 345 | 346 | (define log2 347 | { number --> number } 348 | X -> (/ (log X) (value log2))) 349 | 350 | (define log' 351 | { number --> number --> number } 352 | X B -> (/ (log X) (log B))) 353 | \* ===================================================== *\ 354 | 355 | (define sin 356 | { number --> number } 357 | X -> (let Sgn (sign X) 358 | X1 (fmod (abs X) (value pi*2)) 359 | Sgn1 (if (> X1 (value pi)) (- 0 Sgn) Sgn) 360 | X2 (if (> X1 (value pi)) (- X1 (value pi)) X1) 361 | X3 (if (> X2 (value pi/2)) 362 | (- (value pi) X2) X2) 363 | (* (sin-h X2) Sgn1))) 364 | 365 | (define sin-h 366 | { number --> number } 367 | X -> (sin-sum 3 X X -1 (* X X))) 368 | 369 | (define sin-sum 370 | { number --> number --> number --> number --> number --> number } 371 | I P Sum Sgn X2 -> Sum where (small-enough? P) 372 | I P Sum Sgn X2 -> (let NewP (/ (/ (* P X2) I) (- I 1)) 373 | (sin-sum (+ I 2) NewP (+ Sum (* NewP Sgn)) (- 0 Sgn) X2))) 374 | 375 | (define cos 376 | { number --> number } 377 | X -> (sin (- (value pi/2) X))) 378 | 379 | (define tan 380 | { number --> number } 381 | X -> (/(sin X) (cos X))) 382 | \* ====================================================== *\ 383 | 384 | (define asin 385 | { number --> number } 386 | X -> (error "asin(x) for |x| > 1!~%") where (> (abs X) 1) 387 | X -> (let Sgn (sign X) 388 | X1 (abs X) 389 | (if (< X1 0.7) 390 | (* (asin-h X1) Sgn) 391 | (* (- (value pi/2) (asin-h (sqrt (- 1.0 (square X1))))) Sgn)))) 392 | 393 | (define asin-h 394 | { number --> number } 395 | X -> (asin-sum 3 X X (* X X))) 396 | 397 | (define asin-sum 398 | { number --> number --> number --> number --> number } 399 | I P Sum X2 -> Sum where (small-enough? P) 400 | I P Sum X2 -> (let Ptmp (/ (* (* P X2) (- I 2)) (- I 1)) 401 | (asin-sum (+ I 2) Ptmp (+ Sum (/ Ptmp I)) X2))) 402 | 403 | (define acos 404 | { number --> number } 405 | X -> (error "acos(x) for |x| > 1!~%") where (> (abs X) 1) 406 | X -> (- (value pi/2) (asin X))) 407 | \* ====================================================== *\ 408 | 409 | (define atan 410 | { number --> number } 411 | X -> (let Sgn (sign X) 412 | X1 (abs X) 413 | (if (> X1 1) 414 | (* (atan-gt1 X1) Sgn) 415 | (* (atan-lt1 X1) Sgn)))) 416 | 417 | (define atan-h 418 | { number --> number } 419 | X -> (atan-sum 3 X X -1 (* X X))) 420 | 421 | (define atan-sum 422 | { number --> number --> number --> number --> number --> number } 423 | I P Sum Sgn X2 -> Sum where (small-enough? P) 424 | I P Sum Sgn X2 -> (let Ptmp (* P X2) 425 | (atan-sum (+ I 2) Ptmp (+ Sum (* (/ Ptmp I) Sgn)) (- 0 Sgn) X2))) 426 | 427 | (define atan-lt1 428 | { number --> number } 429 | X -> (let Sgn (sign X) 430 | X1 (abs X) 431 | (if (> X1 0.4142) 432 | (* (- (value pi/4) (atan-h (atan-transf X1)) ) Sgn) 433 | (*(atan-h X1) Sgn)) ) ) 434 | 435 | (define atan-gt1 436 | { number --> number } 437 | X -> (- (value pi/2) (atan-lt1 (/ 1 X)))) 438 | 439 | (define atan-transf 440 | { number --> number } 441 | X -> (/ (- 1 X) (+ 1 X))) 442 | 443 | (define atan2 444 | { number --> number --> number } 445 | 0 0 -> (error "atan2 - undefined") 446 | Y 0 -> (value pi/2) where (> Y 0) 447 | Y 0 -> (- 0 (value pi/2)) where (< Y 0) 448 | Y X -> (atan (/ Y X)) where (> X 0) 449 | Y X -> (+ (atan (/ Y X)) (value pi)) where (>= Y 0) 450 | Y X -> (- (atan (/ Y X)) (value pi))) \* ( < Y 0) *\ 451 | \* ====================================================== *\ 452 | \*================== integer functions ===================*\ 453 | 454 | (define even? 455 | { number --> boolean } 456 | N -> true where (integer? (/ N 2)) 457 | _ -> false) 458 | 459 | (define odd? 460 | { number --> boolean } 461 | N -> true where (integer? (/ (- N 1) 2)) 462 | N -> false) 463 | 464 | (define natural? 465 | { number --> boolean } 466 | X -> (and (>= X 0) (integer? X))) 467 | 468 | (define positive? 469 | { number --> boolean } 470 | N -> (> N 0)) 471 | 472 | (define negative? 473 | { number --> boolean } 474 | N -> (< N 0)) 475 | 476 | (define zero? 477 | { number --> boolean } 478 | N -> (= N 0)) 479 | 480 | \* ==================== shift function ====================== *\ 481 | 482 | (define rsh 483 | {number --> number} 484 | X -> (rsh-h X (/ X 2))) 485 | 486 | (define rsh-h 487 | {number --> number --> number} 488 | X X/2 -> X/2 where (integer? X/2) 489 | X _ -> (rsh (- X 1))) 490 | \* ==================== integer division ====================== *\ 491 | 492 | (define /-pos 493 | { number --> number --> (number * number) } 494 | _ 0 -> (error "division by 0!~%") 495 | A B -> (@p 0 A) where (> B A) 496 | _ B -> (error "divisor must be an integer!~%") where (not(integer? B)) 497 | A B -> (let Pow2 (pow-2div B A 1) 498 | (div-w A (* Pow2 B) Pow2 0))) 499 | 500 | (define div-w 501 | { number --> number --> number --> number --> (number * number) } 502 | A B 1 Q -> (if (<= B A) (@p (+ Q 1) (- A B)) (@p Q A)) 503 | A B P Q -> (if (<= B A) (div-w (- A B) (/ B 2) (/ P 2) (+ Q P)) 504 | (div-w A (/ B 2) (/ P 2) Q))) 505 | 506 | (define pow-2div 507 | \* returns the smallest power of 2, s.t. B*Pow2 > A *\ 508 | { number --> number --> number --> number } 509 | B A Pow2 -> (if (<= B A) (pow-2div (* B 2) A (* Pow2 2)) Pow2)) 510 | 511 | (define divisible-by? 512 | { number --> number --> boolean } 513 | A B -> (= (mod-pos A B) 0)) 514 | 515 | (define prime? 516 | { number --> boolean } 517 | 2 -> true 518 | N -> false where (even? N) 519 | N -> (prime'? N 3 (round(sqrt N)))) 520 | 521 | (define prime'? 522 | { number --> number --> number --> boolean } 523 | _ K Limit -> true where (> K Limit) 524 | N K _ -> false where (divisible-by? N K) 525 | N K Limit -> (prime'? N (+ K 2) Limit)) 526 | 527 | (define mod-pos 528 | { number --> number --> number } 529 | A B -> (let S (pow-2div B A 1) 530 | (div-ww A (* S B) S ))) 531 | 532 | (define div-ww 533 | { number --> number --> number --> number } 534 | A B 1 -> (if (<= B A) (- A B) A) 535 | A B P -> (if (<= B A) (div-ww (- A B) (/ B 2) (/ P 2)) 536 | (div-ww A (/ B 2) (/ P 2)))) 537 | 538 | \* ====================== /mod div mod ========================= *\ 539 | 540 | (define /mod \* remainder has same sign as divisor *\ 541 | { number --> number --> (number * number) } 542 | A B -> (let QR (/-pos (abs A) (abs B)) 543 | (/mod-h B (fst QR) (snd QR) (sign A) (sign B)))) 544 | 545 | (define /mod-h 546 | { number --> number --> number --> number --> number --> (number * number) } 547 | B Q R 1 1 -> (@p Q R) 548 | B Q R -1 -1 -> (@p Q (- 0 R)) 549 | B Q 0 _ _ -> (@p (- 0 Q) 0) 550 | B Q R -1 1 -> (@p (- -1 Q)(- B R)) 551 | B Q R _ _ -> (@p (- -1 Q)(+ B R))) 552 | 553 | (define div 554 | { number --> number --> number } 555 | A B -> (let QR (/-pos (abs A) (abs B)) 556 | (div-h (fst QR) (snd QR) (sign A) (sign B)))) 557 | 558 | (define div-h 559 | { number --> number --> number --> number --> number } 560 | Q _ SA SA -> Q 561 | Q 0 _ _ -> (- 0 Q) 562 | Q _ _ _ -> (- -1 Q)) 563 | 564 | (define mod \* has same sign as divisor B *\ 565 | { number --> number --> number } 566 | A B -> (let QR (/-pos (abs A) (abs B)) 567 | (mod-h B (snd QR) (sign A) (sign B)))) 568 | 569 | (define mod-h 570 | { number --> number --> number --> number --> number } 571 | B 0 _ _ -> 0 572 | B R 1 1 -> R 573 | B R -1 -1 -> (- 0 R) 574 | B R 1 -1 -> (+ B R) 575 | B R -1 1 -> (- B R)) 576 | 577 | \* ================== /rem trunc-div rem ===================== *\ 578 | 579 | (define /rem \* remainder has same sign as dividend *\ 580 | { number --> number --> (number * number) } 581 | A B -> (let QR (/-pos (abs A) (abs B)) 582 | (/rem-h(fst QR) (snd QR) (sign A) (sign B)))) 583 | 584 | (define /rem-h 585 | { number --> number --> number --> number --> (number * number) } 586 | Q R 1 1 -> (@p Q R) 587 | Q R -1 -1 -> (@p Q (- 0 R)) 588 | Q R 1 -1 -> (@p (- 0 Q) R) 589 | Q R _ _ -> (@p (- 0 Q)(- 0 R))) 590 | 591 | (define trunc-div 592 | { number --> number --> number } 593 | A B -> (let QR (/-pos (abs A) (abs B)) 594 | (if (= (sign A) (sign B)) (fst QR) (- 0 (fst QR))))) 595 | 596 | (define rem \* has same sign as dividend A *\ 597 | { number --> number --> number } 598 | A B -> (let QR (/-pos (abs A) (abs B)) 599 | (if (>= A 0) (snd QR) (- 0 (snd QR))))) 600 | 601 | \* ====================== /% div-eucl % =========================== *\ 602 | 603 | (define /% 604 | { number --> number --> (number * number) } 605 | A B -> (let QR (/-pos (abs A) (abs B)) 606 | (/%-h B (fst QR) (snd QR) (sign A) (sign B)))) 607 | 608 | (define /%-h 609 | { number --> number --> number --> number --> number --> (number * number) } 610 | _ Q R 1 1 -> (@p Q R) 611 | _ Q R 1 -1 -> (@p (- 0 Q) R) 612 | _ Q 0 -1 1 -> (@p (- 0 Q) 0) 613 | _ Q 0 _ _ -> (@p Q 0) \* -1 -1 *\ 614 | B Q R -1 1 -> (@p (- -1 Q) (- B R)) 615 | B Q R _ _ -> (@p (+ 1 Q) (- 0 (+ B R)))) \* -1 -1 *\ 616 | 617 | (define div-eucl 618 | { number --> number --> number } 619 | A B -> (let QR (/-pos (abs A) (abs B)) 620 | (adjust-Q (sign A) (sign B)(fst QR)))) 621 | 622 | (define adjust-Q 623 | { number --> number --> number --> number} 624 | 1 1 Q -> Q 625 | -1 -1 Q -> (+ Q 1) 626 | _ _ Q -> (- 0 Q)) 627 | 628 | (define % \* always +ve *\ 629 | { number --> number --> number } 630 | A B -> (let QR (/-pos (abs A) (abs B)) 631 | (if (> A 0) (snd QR) (- (abs B) (snd QR))))) 632 | 633 | (define gcd 634 | { number --> number --> number } 635 | X 0 -> (abs X) 636 | X Y -> (gcd Y (mod X Y))) 637 | 638 | (define lcm 639 | { number --> number --> number } 640 | M N -> (abs(/ (* M N) (gcd M N)))) 641 | 642 | \* moved from auxiliary - now deleted *\ 643 | (define != 644 | { A --> A --> boolean } 645 | X Y -> (not (= X Y))) 646 | 647 | (define max 648 | {number --> number --> number} 649 | M N -> (if (> M N) M N)) 650 | 651 | (define min 652 | {number --> number --> number} 653 | M N -> (if (< M N) M N)) 654 | 655 | ) 656 | -------------------------------------------------------------------------------- /maths/module.shen: -------------------------------------------------------------------------------- 1 | (register-module [[name: maths] 2 | [author: "Willi O Riha"] 3 | [load-fn: maths-load] 4 | [translate: "macro-def.shen" "maths-lib.shen"]]) 5 | 6 | \* load native definitions of math functions for efficiency *\ 7 | (define maths-load-native 8 | {string --> string --> boolean} 9 | _ _ -> true) 10 | 11 | (define maths-load 12 | {A --> boolean} 13 | _ -> (do 14 | (load/tc - "macro-def.shen") 15 | (load "maths-lib.shen") 16 | (maths-load-native (language) (implementation)))) 17 | -------------------------------------------------------------------------------- /modulesys.shen: -------------------------------------------------------------------------------- 1 | \* modulesys - public domain module system for Shen 2 | 3 | ## Description 4 | 5 | Module system is a tool for managing Shen libraries. 6 | 7 | ## Basic usage 8 | 9 | * `(module.use [Mod1 ...])` or `(use-modules [Mod1 ...])` 10 | loads given modules with all their dependencies. Any module already loaded 11 | won't be loaded twice. 12 | 13 | * `(module.reload Mod1)` 14 | reloads given module. 15 | 16 | * `(module.files-to-translate Mod Language Implementation)` 17 | returns a list of module Mod files to translate which can be passed to 18 | a language dependent translator. Note that it loads module with all its 19 | dependencies first. 20 | 21 | * `(module.add-path Dir)` 22 | adds directory to a list where modules are searched. 23 | 24 | ## Module definition 25 | 26 | Sample contents of `mod1/module.shen` where `mod1` is module name: 27 | 28 | (register-module [[load: "file1" "file2"] 29 | [depends: "mod3" mod4]]) 30 | *\ 31 | 32 | (package module [use-modules load/tc register-module 33 | 34 | name depends translate-depends load translate load-fn 35 | unload-fn translate-fn] 36 | 37 | (set *paths* []) 38 | (set *list* []) 39 | (set *db* (trap-error (shen.dict 256) (/. _ (vector 256)))) 40 | (set *fields* [path load translate depends translate-depends load-fn unload-fn 41 | translate-fn]) 42 | 43 | (define add-path 44 | X -> (set *paths* [X | (value *paths*)]) 45 | where (not (element? X (value *paths*)))) 46 | 47 | (define rm-path 48 | X -> (set *paths* (remove X (value *paths*)))) 49 | 50 | (define normalize-id 51 | X -> X where (string? X) 52 | X -> (str X) where (symbol? X)) 53 | 54 | (define normalize-ids 55 | X -> (map (function normalize-id) X) where (cons? X) 56 | X -> [(normalize-id X)]) 57 | 58 | (define add-field 59 | M Field Data Db -> (do (put M fields (adjoin Field (get M fields Db)) Db) 60 | (put M Field Data Db) 61 | true)) 62 | 63 | (define add-module-field 64 | M [Field : X] -> (add-field M Field X (value *db*)) 65 | where (element? Field [load-fn unload-fn translate-fn]) 66 | M [depends : | Xs] -> (add-field M depends (normalize-ids Xs) (value *db*)) 67 | M [Field : | Xs] -> (add-field M Field Xs (value *db*)) 68 | _ _ -> false) 69 | 70 | (define nil-load 71 | -> false) 72 | 73 | (set *nil-load* nil-load) 74 | (set *nil-translate* (/. _ _ [])) 75 | 76 | (define init-module-data 77 | M -> (do (put M path (value *home-directory*) (value *db*)) 78 | (put M load [] (value *db*)) 79 | (put M translate [] (value *db*)) 80 | (put M depends [] (value *db*)) 81 | (put M translate-depends [] (value *db*)) 82 | (put M load-fn (value *nil-load*) (value *db*)) 83 | (put M unload-fn (value *nil-load*) (value *db*)) 84 | (put M translate-fn (value *nil-translate*) (value *db*)) 85 | (put M fields (value *fields*) (value *db*)) 86 | true)) 87 | 88 | (define rm-module-data' 89 | [] _ _ -> true 90 | [X | Xs] M D -> (do (unput M X D) 91 | (rm-module-data' Xs M))) 92 | 93 | (define rm-module-data 94 | M -> (rm-module-data' (get M fields (value *db*)) M (value *db*))) 95 | 96 | (define add-module-data 97 | _ [] -> true 98 | M [X | Xs] -> (do (add-module-field M X) 99 | (add-module-data M Xs))) 100 | 101 | (define register 102 | Def -> (let Name (value *current-module*) 103 | (and (init-module-data Name) 104 | (add-module-data Name Def)))) 105 | 106 | (define register-module 107 | Def -> (register Def)) 108 | 109 | (define call-module-unload 110 | M -> (let F (get M unload-fn (value *db*)) 111 | (if (= F (value *nil-load*)) 112 | true 113 | ((function F) unload)))) 114 | 115 | (define forget-module 116 | M -> true where (not (element? (normalize-id M) (value *list*))) 117 | M -> (let M-id (normalize-id M) 118 | . (call-module-unload M-id) 119 | . (set *list* (remove M-id (value *list*))) 120 | (rm-module-data M-id))) 121 | 122 | (define manifest-exists? 123 | F -> (trap-error (do (close (open (cn F "/module.shen") in)) 124 | true) 125 | (/. E false))) 126 | 127 | (define in-directory 128 | Dir Proc Err -> (let Prev (value *home-directory*) 129 | (trap-error (let Ret (Proc (cd Dir)) 130 | . (cd Prev) 131 | Ret) 132 | (/. E (do (cd Prev) 133 | (Err E)))))) 134 | 135 | (define find-module-dir 136 | M [] -> (error "Unable to locate module ~A" M) 137 | M [D | Ds] -> (let Dir (cn D (cn "/" M)) 138 | (if (manifest-exists? Dir) 139 | Dir 140 | (find-module-dir M Ds)))) 141 | 142 | (define load-manifest' 143 | M S -> (let . (set *current-module* M) 144 | . (load/tc - "module.shen") 145 | . (set *current-module* "") 146 | S)) 147 | 148 | (define module-error 149 | S M R E -> (do (rm-module-data M) 150 | (set *current-module* "") 151 | (error "~A ~S: ~S" S M (error-to-string E)) 152 | R)) 153 | 154 | (define load-manifest 155 | M Ds -> (in-directory (find-module-dir M Ds) 156 | (load-manifest' M) 157 | (module-error "Loading manifest" M ""))) 158 | 159 | (define module-trans-deps 160 | M -> (let D (get M translate-depends (value *db*)) 161 | (if (empty? D) 162 | (get M depends (value *db*)) 163 | D))) 164 | 165 | (define resolve-deps' 166 | {string --> (list string) --> get-deps-fn --> (string --> boolean) 167 | --> (list string) --> (list string)} 168 | _ [] _ _ Acc -> Acc 169 | P [D | Ds] Get Pred Acc -> (resolve-deps' P Ds Get Pred Acc) where (Pred D) 170 | P [D | Ds] Get Pred Acc -> (let Ps [P "." | (value *paths*)] 171 | Dir (load-manifest D Ps) 172 | Acc [D | Acc] 173 | Acc (resolve-deps' Dir (Get D) Get Pred Acc) 174 | (resolve-deps' P Ds Get Pred Acc))) 175 | 176 | (define remove-dups' 177 | [] Acc -> (reverse Acc) 178 | [X | Xs] Acc -> (remove-dups' Xs Acc) where (element? X Acc) 179 | [X | Xs] Acc -> (remove-dups' Xs [X | Acc])) 180 | 181 | (define remove-dups 182 | X -> (remove-dups' X [])) 183 | 184 | (define resolve-deps 185 | Deps Get Pred -> (remove-dups (resolve-deps' "." Deps Get Pred []))) 186 | 187 | (define load-module-files 188 | [] -> true 189 | [F | Fs] -> (do (load F) 190 | (load-module-files Fs))) 191 | 192 | (define load-module-sources 193 | M -> (let F (get M load-fn (value *db*)) 194 | R (if (= F (value *nil-load*)) 195 | (load-module-files (get M load (value *db*))) 196 | ((function F) load)) 197 | . (set *list* [M | (value *list*)]) 198 | R)) 199 | 200 | (define load-module 201 | M -> (in-directory (get M path (value *db*)) 202 | (/. _ (load-module-sources M)) 203 | (module-error "Failed loading" M false))) 204 | 205 | (define load-modules 206 | [] -> true 207 | [M | Ms] -> (do (load-module M) 208 | (load-modules Ms))) 209 | 210 | (define use 211 | Ms -> (let Mods (resolve-deps (normalize-ids Ms) 212 | (/. M (get M depends (value *db*))) 213 | (/. X (element? X (value *list*)))) 214 | (load-modules Mods))) 215 | 216 | (define use-modules 217 | Ms -> (use Ms)) 218 | 219 | (define reload 220 | M -> (do (forget-module M) 221 | (use [M]))) 222 | 223 | (define fullpath 224 | P Files -> (map (/. X (cn P X)) Files)) 225 | 226 | (define ls-module-trans-files 227 | M Lang Impl Acc -> 228 | (in-directory 229 | (get M path (value *db*)) 230 | (/. Dir (let F (get M translate-fn (value *db*)) 231 | (append Acc (fullpath Dir 232 | (if (= F (value *nil-translate*)) 233 | (let L (get M translate (value *db*)) 234 | (if (empty? L) 235 | (get M load (value *db*)) 236 | L)) 237 | ((function F) Lang Impl)))))) 238 | (module-error "Failed translating" M []))) 239 | 240 | (define collect-trans-files 241 | [] _ _ Acc -> Acc 242 | [M | Ms] Lang Impl Acc -> 243 | (collect-trans-files Ms Lang Impl (ls-module-trans-files M Lang Impl Acc))) 244 | 245 | (define files-to-translate 246 | M Lang Impl -> (let M-id (normalize-id M) 247 | . (use [M]) 248 | Mods (resolve-deps [M-id] 249 | (function module-trans-deps) 250 | (/. _ false)) 251 | (collect-trans-files Mods Lang Impl []))) 252 | 253 | (define load/tc 254 | Tc File -> (let Old-tc (if (tc?) + -) 255 | . (tc Tc) 256 | R (trap-error (load File) 257 | (/. E (do (tc Old-tc) 258 | (error (error-to-string E))))) 259 | . (tc Old-tc) 260 | R)) 261 | 262 | (datatype module-types 263 | X : string; 264 | ______________ 265 | X : module-id; 266 | 267 | X : symbol; 268 | ______________ 269 | X : module-id; 270 | 271 | X : module-id; 272 | _____________ 273 | X : module-list; 274 | 275 | X : (list module-id); 276 | _________________ 277 | X : module-list; 278 | ) 279 | 280 | 281 | (declare files-to-translate 282 | [module-id --> string --> string --> [list string]]) 283 | (declare use [module-list --> boolean]) 284 | (declare use-modules [module-list --> boolean]) 285 | (declare reload [module-id --> boolean]) 286 | (declare load/tc [symbol --> string --> symbol])) 287 | -------------------------------------------------------------------------------- /modulesys_howto.md: -------------------------------------------------------------------------------- 1 | # Module system usage 2 | 3 | This document explains module system usage. For a complete documentation read 4 | [Modules](https://github.com/vasil-sd/shen-libs/wiki/Modules) wiki page. 5 | 6 | ## How to setup module system 7 | 8 | The simplest way to get module system sources is to clone shen-libs repo into 9 | some directory, say `shen-libs`: 10 | 11 | git clone https://github.com/vasil-sd/shen-libs.git shen-libs 12 | 13 | So in `shen-libs` directory you will see `modulesys.shen` and directories of 14 | libraries. 15 | 16 | You may want to store your own libraries in separate directory, e.g. 17 | `my-libs`. Create that directory. 18 | 19 | Then write into your Shen init file (if you have one): 20 | 21 | (load "$shen-libs/modulesys.shen") 22 | (module.add-path "$my-libs") 23 | (module.add-path "$shen-libs") 24 | 25 | Where `$shen-libs` is a full path of your `shen-libs` directory and `$my-libs` 26 | is a full path of your `my-lib`. First line loads module system. Second and 27 | third lines set a list of paths where module system will search modules. 28 | 29 | ## How to use a module 30 | 31 | When `modulesys.shen` is loaded and `*modules-paths*` appropriately set then 32 | to load modules `mod1` and `mod2` you need to type 33 | 34 | (module.use ["mod1" "mod2"]) 35 | 36 | or 37 | 38 | (use-modules ["mod1" "mod2"]) 39 | 40 | If in development process you modified `mod2` module then it won't be reloaded 41 | by `module.use`. In that case you have to use 42 | 43 | (module.reload mod2) 44 | 45 | ## How to create a module 46 | 47 | You have implemented something and want to make it a module. 48 | 49 | First, give it a name. In order to avoid name clashes look over modules in 50 | shen-libs. For instance the chosen name is `foo`. And you want to store it in 51 | `my-libs` directory (listed in `modules.*paths*`). 52 | 53 | So create a directory `foo` in `my-libs`. Put your module sources there. To 54 | make the module available for module system create in `my-libs` a module 55 | description (manifest) file `module.shen`. Its contents may look like this: 56 | 57 | (register-module [[author: "Me"] 58 | [license: "GPL"] 59 | [desc: "A module implementing X."] 60 | [depends: "bar" "baz"] 61 | [load: "src.shen" "src1.shen" "src2.shen"]]) 62 | 63 | where `src.shen`, `src1.shen`, `src2.shen` are sources of module `foo`. This 64 | manifest tells module system that a module `foo` depends on modules `bar` and 65 | `baz` and to use it Shen needs to load files `src.shen`, `src1.shen`, 66 | `src2.shen`. 67 | 68 | For example of a working module see `defstruct` in shen-libs. 69 | -------------------------------------------------------------------------------- /packages/packages.shen: -------------------------------------------------------------------------------- 1 | \* packages.shen --- a simple package requirement facility 2 | 3 | Copyright (C) 2011, Eric Schulte 4 | 5 | *** License: 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions are 9 | met: 10 | 11 | - Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 14 | - Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | *** Commentary: 31 | 32 | The following configures the load-path to load all packages in shen-libs/ 33 | 34 | (load "../file-system/file-system.shen") 35 | (load "packages.shen") 36 | (map (lambda P 37 | (if (= ".git" (hd (reverse (split-paths P)))) 38 | false 39 | (set *package-path* (adjoin P (value *package-path*))))) 40 | (directory-list "../")) 41 | 42 | after which packages may be loaded as follows 43 | 44 | (require sequence) 45 | 46 | *** Code: *\ 47 | (package packages- [*packages* *package-path* loaded? require 48 | \* symbols included from file-system *\ 49 | join-paths 50 | \* symbols included from sequence *\ 51 | take drop take-while drop-while range flatten 52 | filter complement seperate zip indexed reduce 53 | mapcon partition partition-with unique frequencies 54 | shuffle pick remove-first interpose subset? 55 | cartesian-product] 56 | 57 | (set *packages* []) 58 | (set *package-path* []) 59 | 60 | (define loaded? 61 | {symbol --> boolean} 62 | \* check if a package has been loaded *\ 63 | Pkg -> (element? Pkg (value *packages*))) 64 | 65 | (define require 66 | \* load a package if possible return boolean indiciating successful load *\ 67 | {symbol --> boolean} 68 | Pkg -> (or (loaded? Pkg) 69 | (and (require- (@s (str Pkg) ".shen") (value *package-path*)) 70 | (do (set *packages* (adjoin Pkg (value *packages*))) true)))) 71 | 72 | (define require- 73 | {string --> (list string) --> boolean} 74 | _ [] -> false 75 | Path [Dir|Dirs] -> (if (try-load (join-paths Dir Path)) 76 | true 77 | (require- Path Dirs))) 78 | 79 | (define try-load 80 | {string --> boolean} 81 | Path -> (trap-error (do (load Path) true) 82 | (lambda E false))) 83 | 84 | ) 85 | -------------------------------------------------------------------------------- /pattern-matching/module.shen: -------------------------------------------------------------------------------- 1 | (register-module [[name: pattern-matching] 2 | [author: "Kjetil Matheussen"] 3 | [load: "pattern-matching.shen"]]) 4 | -------------------------------------------------------------------------------- /pattern-matching/pattern-matching.shen: -------------------------------------------------------------------------------- 1 | \* pattern-matching.shen --- Helper functions to create custom pattern matchers in shen 2 | 3 | Copyright (C) 2013, Kjetil S. Matheussen 4 | 5 | *** License: 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions are 9 | met: 10 | 11 | - Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 14 | - Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | 31 | 32 | About: 33 | ====== 34 | 35 | '(create-pattern-matching-variables Pattern Value)' returns an optimized 36 | list of variable names and values based on the provided 'Pattern' 37 | and 'Value' arguments. The returned list can be used directly in 38 | a shen 'let' block. 39 | 40 | The function matches combinations of lists, tuples, vectors and strings. 41 | 42 | Note that the same task could possibly also be achieved by using 43 | the shen. function, which is part of the shen parser. 44 | But 'create-pattern-matching-variables' is documented. 45 | 46 | 47 | Example 1: 48 | 49 | (create-pattern-matching-variables [cons A []] 50 | [cons a []])) 51 | -> 52 | [A (head (cons a NIL))] 53 | | | 54 | | | 55 | | +--- Value 56 | | 57 | +--- Variable name 58 | 59 | 60 | Example 2: 61 | 62 | (create-pattern-matching-variables [cons A [cons B C]] 63 | [cons a [cons b c]]) 64 | -> 65 | [TempMatchVariable1168 (cons a (cons b c)) 66 | A (head TempMatchVariable1168) 67 | TempMatchVariable1169 (tail TempMatchVariable1168) 68 | B (head TempMatchVariable1169) 69 | C (tail TempMatchVariable1169)] 70 | | | 71 | | | 72 | | +--- Values 73 | | 74 | +--- Variable names 75 | 76 | 77 | 78 | 79 | *\ 80 | 81 | (package pattern-matching [create-pattern-matching-variables] 82 | 83 | (define create-cons-match-code 84 | M Ms HeadF TailF Value -> (let Try (append (create-pattern-matching-variables M [HeadF Value]) 85 | (create-pattern-matching-variables Ms [TailF Value])) 86 | (if (and (cons? Value) 87 | (> (length Try) 2)) 88 | (let TempMatchVariable (gensym (protect TempMatchVariable)) 89 | (append [TempMatchVariable Value] 90 | (create-pattern-matching-variables M [HeadF TempMatchVariable]) 91 | (create-pattern-matching-variables Ms [TailF TempMatchVariable]))) 92 | Try))) 93 | 94 | (define create-pattern-matching-variables 95 | [] _ -> [] 96 | [@v [vector 0]] _ -> [] 97 | [cons M Ms] Value -> (create-cons-match-code M Ms head tail Value) 98 | [@p M Ms] Value -> (create-cons-match-code M Ms fst snd Value) 99 | [@s M Ms] Value -> (create-cons-match-code M Ms hdstr tlstr Value) 100 | [@v M Ms] Value -> (create-cons-match-code M Ms hdv tlv Value) 101 | Var _ -> [] where (= Var _) 102 | Var Value -> [Var Value]) 103 | 104 | ) 105 | 106 | 107 | \* 108 | Various Tests: 109 | 110 | (map PPRINT 111 | (create-pattern-matching-variables [cons A []] 112 | [cons a []])) 113 | (map PPRINT 114 | (create-pattern-matching-variables [cons A [cons B C]] 115 | [cons a [cons b c]])) 116 | (map PPRINT 117 | (create-pattern-matching-variables [cons A [cons B C]] 118 | hepp)) 119 | 120 | (map PPRINT 121 | (create-pattern-matching-variables [cons [@v A [@v B [@v [vector 0]]]] C] 122 | [cons [@v a b <>] c])) 123 | (map PPRINT 124 | (create-pattern-matching-variables [cons [@s A [@s B1 B2]] C] 125 | [cons "ab gakkgakk" c])) 126 | (map PPRINT 127 | (create-pattern-matching-variables [cons [@s A [@s B1 B2]] C] 128 | [cons "" c])) 129 | (map PPRINT 130 | (create-pattern-matching-variables [cons [@p A B] C] 131 | [cons [@p a b] c])) 132 | (map PPRINT 133 | (create-pattern-matching-variables [cons [@p A [@p B1 B2]] C] 134 | [cons [@p a b1 b2] c])) 135 | (map PPRINT 136 | (create-pattern-matching-variables [cons [@p [cons A1 A2] B] C] 137 | [cons [@p [cons a1 a2] b] c])) 138 | 139 | (map PPRINT 140 | (create-pattern-matching-variables [cons A [cons [cons B []] _]] 141 | [cons a [cons [cons b []] _]])) 142 | 143 | *\ 144 | 145 | -------------------------------------------------------------------------------- /regexp/regexp.shen: -------------------------------------------------------------------------------- 1 | \* regexp.shen --- regular expressions for shen 2 | 3 | Copyright (C) 2011, Eric Schulte 4 | 5 | *** License: 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions are 9 | met: 10 | 11 | - Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 14 | - Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | *** Commentary: 31 | 32 | This library implements regular expressions for shen. String regular 33 | expressions are compiled to shen functions which accept a string argument 34 | and return an re-state object. 35 | 36 | See the bottom portion of this file for external functions which may be 37 | used as an access point for compiling and using regular expressions. 38 | 39 | Some examples are included below. 40 | 41 | Character classes. 42 | 43 | (1-) (match-strings (re-search "[:digit:]+" "Lorem ipsum dolor sit, 26.")) 44 | ["26"] 45 | 46 | (2-) (match-strings (re-search "\\d+" "Lorem ipsum dolor sit, 26.")) 47 | ["26"] 48 | 49 | (3-) (match-strings (re-search "\\w+" "Lorem ipsum dolor sit amet, 26, mattis eget.")) 50 | ["Lorem"] 51 | 52 | Alternatives grouped with [...]'s. 53 | 54 | (4-) (match-strings (re-search "d[olr]+" "Lorem ipsum dolor sit, 26.")) 55 | ["dolor"] 56 | 57 | Nested regular expressions and alternatives with (...|...). 58 | 59 | (5-) (do-matches (/. X (hd (match-strings X))) "(ipsum|eget)" 60 | "Lorem ipsum dolor sit amet, 26, mattis eget.") 61 | ["ipsum" "eget"] 62 | 63 | Finally it is also possible to express regular expressions using S-exprs rather 64 | than strings, for example 65 | 66 | (1-) (match-strings (re-search [: d [+ [| o l r]]] "Lorem ipsum dolor sit, 26.")) 67 | ["dolor"] 68 | 69 | The syntax for S-expr regular expressions is as follows. 70 | [: ...] ---------------- consequtive regular expressions 71 | [| ...] ---------------- regular expression alternatives 72 | [* ...] and [+ ...] ---- repeating regular expressions 73 | [*? R1 R2] ------------- compile R1 as a lazy regular expression followed by R2 74 | 75 | *** Code: *\ 76 | (trap-error 77 | (do (require string) 78 | (require sequence)) 79 | (/. E 80 | (do (load "../string/string.shen") 81 | (load "../sequence/sequence.shen")))) 82 | 83 | (datatype re-state 84 | String : string; 85 | Index : number; 86 | Matches : [number]; 87 | ============================= 88 | (@p (@p String Index) Matches) : re-state; 89 | 90 | Simple-state : string; 91 | ======================= 92 | Simple-state : re-state; 93 | 94 | _________________ 95 | false : re-state;) 96 | 97 | (datatype re-next 98 | Re-string : string; 99 | =================== 100 | Re-string : re-next; 101 | 102 | ___________________ 103 | eos : re-next;) 104 | 105 | (package regexp- [new-state state index matches next increment 106 | match-strings starting-at successful? re re-search 107 | re-search-from do-matches replace-regexp 108 | \* symbols included from sequence *\ 109 | take drop take-while drop-while range flatten 110 | filter complement seperate zip indexed reduce 111 | mapcon partition partition-with unique frequencies 112 | shuffle pick remove-first interpose subset? 113 | cartesian-product 114 | \* symbols included from string *\ 115 | takestr dropstr substr length-str index-str 116 | reverse-str starts-with substr? replace-str 117 | join split trim-left trim-right chomp trim] 118 | \******************************************************************************* 119 | * re-state holds the state and match data of regular expressions 120 | *\ 121 | 122 | 123 | (define new-state 124 | {re-state --> re-state} 125 | (@p (@p String Index) Matches) -> (@p (@p String Index) Matches) 126 | String -> (@p (@p String 0) []) where (string? String)) 127 | 128 | (define state 129 | {re-state --> (string * number)} 130 | (@p (@p String Index) Matches) -> (@p String Index) 131 | String -> (@p String 0) where (string? String)) 132 | 133 | (define index 134 | {re-state --> number} 135 | X -> (snd (state X))) 136 | 137 | (define matches 138 | {re-state --> [number]} 139 | (@p (@p String Index) Matches) -> Matches 140 | String -> [] where (string? String)) 141 | 142 | (define next 143 | {re-state --> re-next} 144 | (@p (@p String Index) Matches) -> (trap-error (pos String Index) (/. _ eos)) 145 | String -> (next (new-state String)) where (string? String) 146 | What -> (print (make-string "what the ~S" What))) 147 | 148 | (define increment 149 | {re-state --> re-state} 150 | (@p (@p String Index) Matches) -> (@p (@p String (+ 1 Index)) Matches) 151 | String -> (increment (new-state String)) where (string? String)) 152 | 153 | (define match-strings 154 | {re-state --> [string]} 155 | false -> [] 156 | String -> [] where (string? String) 157 | (@p (@p S I) [A B|MS]) -> [(substr S A B)|(match-strings (@p (@p S I) MS))]) 158 | 159 | (define starting-at 160 | {re-state --> number --> re-state} 161 | (@p (@p String _) Matches) Index -> (@p (@p String Index) Matches) 162 | String Index -> (starting-at (new-state String) Index) where (string? String)) 163 | 164 | (define successful? 165 | {re-state --> boolean} 166 | false -> false 167 | _ -> true) 168 | 169 | \******************************************************************************* 170 | * compilation of a regular expression from a string representation 171 | *\ 172 | (define re-or 173 | \* Create a disjunction of regular expressions *\ 174 | [] -> (lambda _ false) 175 | [R|Rs] -> (lambda State 176 | (let Result ((re R) State) 177 | (if (successful? Result) 178 | Result 179 | ((re-or Rs) State))))) 180 | 181 | (define re-and 182 | \* Create a conjunction of regular expressions *\ 183 | [] -> (lambda X X) 184 | [R|Rs] -> (lambda State 185 | (let Result ((re R) State) 186 | (if (successful? Result) 187 | ((re-and Rs) Result) 188 | false)))) 189 | 190 | (define re-repeat 191 | \* Repeatedly apply a regular expression until it fails *\ 192 | R -> (let RC (re R) 193 | (lambda State 194 | (let Result (RC State) 195 | (if (successful? Result) 196 | ((re-repeat RC) Result) 197 | State))))) 198 | 199 | (define with-match 200 | \* Wrap a regular expression into a match. *\ 201 | E -> (lambda State 202 | (let Beg (index State) 203 | Result ((re E) State) 204 | (if (successful? Result) 205 | (@p (state Result) [(index Result) Beg|(matches Result)]) 206 | false)))) 207 | 208 | (define re-repeat-lazy 209 | R1 [] -> (lambda State State) 210 | R1 R2 -> (let RC1 (re R1) 211 | RC2 (re R2) 212 | (lambda State 213 | (let Result1 (RC2 State) 214 | (if (successful? Result1) 215 | Result1 216 | (let Result2 (RC1 State) 217 | (if (successful? Result2) 218 | ((re-repeat-lazy R1 R2) Result2) 219 | false))))))) 220 | 221 | (define compile-1 222 | \* Condense (...|...) and [...] control constructs *\ 223 | [] -> [] 224 | ["("|Rs] -> (let Inside (take-while (complement (= ")")) Rs) 225 | Leftover (tl (drop-while (complement (= ")")) Rs)) 226 | Split (remove ["|"] (partition-with (= "|") Inside)) 227 | (cons (with-match 228 | (re-or (map (/. X (re-and (compile-2 (compile-1 X)))) 229 | Split))) 230 | (compile-1 Leftover))) 231 | ["["|Rs] -> (let Inside (take-while (complement (= "]")) Rs) 232 | Leftover (tl (drop-while (complement (= "]")) Rs)) 233 | (cons (re-or Inside) (compile-1 Leftover))) 234 | [R|Rs] -> (cons R (compile-1 Rs))) 235 | 236 | (define compile-2 237 | \* Handle + and * control constructs *\ 238 | [] -> [] 239 | [R "+" "?" |Rs] -> (cons R (compile-2 [R "*" "?"|Rs])) 240 | [R "+"|Rs] -> (cons R (compile-2 [R "*"|Rs])) 241 | [R1 "*" "?" R2|Rs] -> (cons (re-repeat-lazy R1 R2) (compile-2 Rs)) 242 | [R1 "*" "?"|Rs] -> (cons (re-repeat-lazy R1 []) (compile-2 Rs)) 243 | [R "*"|Rs] -> (cons (re-repeat R) (compile-2 Rs)) 244 | [R|Rs] -> (cons R (compile-2 Rs))) 245 | 246 | (define parse 247 | \* Convert a string regexp into a list of compiled regular expressions and strings *\ 248 | {string --> (list A)} 249 | "" -> [] 250 | \* Character Classes *\ 251 | (@s "\\d" Str) -> [(to-re re-digit?) |(parse Str)] 252 | (@s "[:digit:]" Str) -> [(to-re re-digit?) |(parse Str)] 253 | (@s "\\D" Str) -> [(to-re (complement re-digit?)) |(parse Str)] 254 | (@s "\\s" Str) -> [(to-re re-space?) |(parse Str)] 255 | (@s "[:space:]" Str) -> [(to-re re-space?) |(parse Str)] 256 | (@s "\\S" Str) -> [(to-re (complement re-space?)) |(parse Str)] 257 | (@s "\\a" Str) -> [(to-re re-alpha?) |(parse Str)] 258 | (@s "[:alpha:]" Str) -> [(to-re re-alpha?) |(parse Str)] 259 | (@s "\\A" Str) -> [(to-re (complement re-alpha?)) |(parse Str)] 260 | (@s "\\w" Str) -> [(to-re re-word?) |(parse Str)] 261 | (@s "[:word:]" Str) -> [(to-re re-word?) |(parse Str)] 262 | (@s "\\W" Str) -> [(to-re (complement re-word?)) |(parse Str)] 263 | \* Beginning and end markers *\ 264 | \** (@s "^" Str) -> [beginning-of-string? | (parse Str)] **\ 265 | (@s "$" Str) -> [end-of-string? | (parse Str)] 266 | \* Control characters *\ 267 | (@s "(" Str) -> ["("|(parse Str)] (@s ")" Str) -> [")"|(parse Str)] 268 | (@s "[" Str) -> ["["|(parse Str)] (@s "]" Str) -> ["]"|(parse Str)] 269 | (@s "+" Str) -> ["+"|(parse Str)] (@s "*" Str) -> ["*"|(parse Str)] 270 | (@s "|" Str) -> ["|"|(parse Str)] (@s "?" Str) -> ["?"|(parse Str)] 271 | \* Escape'd and Regular Characters *\ 272 | (@s "\\" C Str) -> [(to-re (= C))|(parse Str)] 273 | (@s C Str) -> [(to-re (= C))|(parse Str)]) 274 | 275 | (define to-re 276 | \* Convert a boolean string matcher into a regular expression *\ 277 | {(string --> boolean) --> regexp} 278 | X -> (lambda S (let Next (next S) 279 | (if (and (not (= eos Next)) (X Next)) 280 | (increment S) false)))) 281 | 282 | (define beginning-of-string? 283 | {re-state --> re-state} 284 | S -> (if (= 0 (index S)) S false)) 285 | 286 | (define end-of-string? 287 | {re-state --> re-state} 288 | S -> (if (= eos (next S)) S false)) 289 | 290 | (define re-digit? 291 | {string --> boolean} 292 | X -> (element? X ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9"])) 293 | 294 | (define re-alpha? 295 | {string --> boolean} 296 | X -> (element? X ["z" "y" "x" "w" "v" "u" "t" "s" "r" "q" "p" "o" "n" 297 | "m" "l" "k" "j" "i" "h" "g" "f" "e" "d" "c" "b" "a" 298 | "Z" "Y" "X" "W" "V" "U" "T" "S" "R" "Q" "P" "O" "N" 299 | "M" "L" "K" "J" "I" "H" "G" "F" "E" "D" "C" "B" "A"])) 300 | 301 | (define re-word? 302 | {string --> boolean} 303 | X -> (or (re-digit? X) (re-alpha? X))) 304 | 305 | (define re-space? 306 | {string --> boolean} 307 | X -> (element? X [" " " " " 308 | "])) 309 | 310 | \******************************************************************************* 311 | * External functions 312 | *\ 313 | (define re 314 | \* Compile a string or S-expr to a regular expression *\ 315 | Str -> (re-and (compile-2 (compile-1 (parse Str)))) where (string? Str) 316 | digit -> (to-re re-digit?) 317 | space -> (to-re re-space?) 318 | alpha -> (to-re re-alpha?) 319 | word -> (to-re re-word?) 320 | Sym -> (re-and (map (function re) (explode (str Sym)))) where (symbol? Sym) 321 | [- A B] -> (re-range A B) 322 | [| |RS] -> (re-or RS) 323 | [bar! |RS] -> (re-or RS) 324 | [: |RS] -> (re-and RS) 325 | [m |RS] -> (re-match RS) 326 | [+ R] -> (re [: R [* R]]) 327 | [* R] -> (re-repeat R) 328 | [+? A B] -> [: A (re-repeat-lazy A B)] 329 | [+? A] -> [: A (re-repeat-lazy A [])] 330 | [*? A B] -> (re-repeat-lazy A B) 331 | [*? A] -> (re-repeat-lazy A []) 332 | CS -> (re [:|CS]) where (cons? CS) 333 | X -> X) 334 | 335 | (define re-search 336 | \* Parse and search for a regular expression in a string. *\ 337 | {string --> string --> match-data} 338 | Re String -> (re-search-from Re String 0)) 339 | 340 | (define re-search-from 341 | \* Parse and search for a regular expression in a string starting at arg3. *\ 342 | {string --> string --> number --> string} 343 | Re Str Ind -> (re-search- (with-match (re Re)) 344 | (starting-at (new-state Str) Ind))) 345 | 346 | (define re-search- 347 | \* Continue searching forward in for arg1 in arg2 until success or eos *\ 348 | {regex --> re-state --> match-data} 349 | Re State -> (let Try (Re State) 350 | (if (= false Try) 351 | (if (= eos (next State)) 352 | false 353 | (re-search- Re (increment State))) 354 | Try))) 355 | 356 | (define do-matches 357 | \* Call a function on every match of arg2 in arg3 *\ 358 | {(match-data --> A) --> string --> string --> (list A)} 359 | Fn Re Str -> (do-matches- Fn (with-match (re Re)) (new-state Str))) 360 | 361 | (define do-matches- 362 | \* Call arg1 on the match data from every match of arg2 in arg3 *\ 363 | {(match-data --> A) --> regexp --> re-state --> (list A)} 364 | Fn Re State -> (let Try (Re State) 365 | (if (= false Try) 366 | (if (= eos (next State)) 367 | [] 368 | (do-matches- Fn Re (increment State))) 369 | (cons (Fn Try) 370 | (do-matches- Fn Re (@p (state Try) [])))))) 371 | 372 | (define replace-regexp 373 | \* replace all matches of arg1 with arg2 in arg3 *\ 374 | {string --> string --> string --> string} 375 | Regexp Replace String -> 376 | (reduce (/. Match Acc 377 | (@s (substr Acc 0 (nth 2 Match)) 378 | Replace 379 | (substr Acc (nth 1 Match) (length-str Acc)))) 380 | String (reverse (do-matches (function snd) Regexp String)))) 381 | 382 | ) 383 | -------------------------------------------------------------------------------- /sequence/sequence.shen: -------------------------------------------------------------------------------- 1 | \* sequence.shen --- Sequence utilities for shen 2 | 3 | Copyright (C) 2011, Eric Schulte 4 | 5 | *** License: 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions are 9 | met: 10 | 11 | - Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 14 | - Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | *** Commentary: 31 | 32 | This library implements a number of sequence utilities commonly 33 | found in functional languages. 34 | 35 | *** Code: *\ 36 | (datatype nested 37 | ____________ 38 | A : nested; 39 | ___________________ 40 | (list A) : nested;) 41 | 42 | (package sequence- [take drop take-while drop-while range flatten 43 | filter complement seperate zip indexed reduce 44 | mapcon partition partition-with unique frequencies 45 | shuffle pick remove-first interpose subset? 46 | cartesian-product] 47 | 48 | (define take-aux 49 | {number --> (list A) --> (list A) --> (list A)} 50 | _ [] Acc -> (reverse Acc) 51 | 0 _ Acc -> (reverse Acc) 52 | N [A | Rest] Acc -> (take-aux (- N 1) Rest [A | Acc])) 53 | 54 | (define take 55 | \* take and return N elements from the front of a list *\ 56 | {number --> (list A) --> (list A)} 57 | N L -> (take-aux N L [])) 58 | 59 | (define drop 60 | \* drop N elements from the front of a list *\ 61 | {number --> (list A) --> (list A)} 62 | _ [] -> [] 63 | 0 AS -> AS 64 | N [A|AS] -> (drop (- N 1) AS)) 65 | 66 | (define take-while-aux 67 | {(A --> boolean) --> (list A) --> (list A) --> (list A)} 68 | _ [] Acc -> (reverse Acc) 69 | Fn [A | Rest] Acc -> (take-while-aux Fn Rest [A | Acc]) where (Fn A) 70 | _ _ Acc -> (reverse Acc)) 71 | 72 | (define take-while 73 | \* take elements of a list while they satisfy a function *\ 74 | {(A --> boolean) --> (list A) --> (list A)} 75 | Fn L -> (take-while-aux Fn L [])) 76 | 77 | (define drop-while 78 | \* drop elements of a list while they satisfy a function *\ 79 | {(A --> boolean) --> (list A) --> (list A)} 80 | _ [] -> [] 81 | Fn [A|AS] -> (if (Fn A) (drop-while Fn AS) [A|AS])) 82 | 83 | (define range 84 | \* return a list of integers from X to Y *\ 85 | {number --> number --> [number]} 86 | X X -> [X] 87 | X Y -> [X|(range (if (> X Y) (- X 1) (+ X 1)) Y)]) 88 | 89 | (define flatten-aux 90 | {nested --> (list A) --> (list A)} 91 | [] Acc -> Acc 92 | [X | Rest] Acc -> (flatten-aux Rest (flatten-aux X Acc)) where (cons? X) 93 | [X | Rest] Acc -> (flatten-aux Rest [X | Acc])) 94 | 95 | (define flatten 96 | \* flatten a list of elements *\ 97 | {nested --> (list A)} 98 | [] -> [] 99 | L -> (reverse (flatten-aux L []))) 100 | 101 | (define filter-aux 102 | {(A --> boolean) --> (list A) --> (list A) --> (list A)} 103 | Test [] Acc -> (reverse Acc) 104 | Test [X | Y] Acc -> (filter-aux Test Y [X | Acc]) where (Test X) 105 | Test [X | Y] Acc -> (filter-aux Test Y Acc)) 106 | 107 | (define filter 108 | \* return those elements of a list which satisfy a given function *\ 109 | {(A --> boolean) --> (list A) --> (list A)} 110 | Test X -> (filter-aux Test X [])) 111 | 112 | (define complement 113 | \* return a function which is the complement of the given function *\ 114 | {(A --> boolean) --> (A --> boolean)} 115 | Fn -> (/. A (not (Fn A)))) 116 | 117 | (define separate-aux 118 | {(A --> boolean) --> (list A) --> (list A) --> (list A) 119 | --> ((list A) * (list A))} 120 | Test [] A1 A2 -> (@p A1 A2) 121 | Test [A | Rest] A1 A2 -> (separate-aux Test Rest [A | A1] A2) where (Test A) 122 | Test [A | Rest] A1 A2 -> (separate-aux Test Rest A1 [A | A2])) 123 | 124 | (define separate 125 | \* separate a list into those that do and don't satisfy a boolean function *\ 126 | {(A --> boolean) --> (list A) --> ((list A) * (list A))} 127 | Test L -> (separate-aux Test L [] [])) 128 | 129 | (define zip-aux 130 | {(list A) --> (list B) --> (list (A * B)) --> (list (A * B))} 131 | _ [] Acc -> (reverse Acc) 132 | [] _ Acc -> (reverse Acc) 133 | [A | A-rest] [B | B-rest] Acc -> (zip-aux A-rest B-rest [(@p A B) | Acc])) 134 | 135 | (define zip 136 | \* combine two lists returning a list of tuples of their elements *\ 137 | {(list A) --> (list B) --> [(A * B)]} 138 | A B -> (zip-aux A B [])) 139 | 140 | (define indexed- 141 | {number --> (list A) --> (list (number * A)) --> (list (number * A))} 142 | _ [] Acc -> (reverse Acc) 143 | N [A | AS] Acc -> (indexed- (+ N 1) AS [(@p N A) | Acc])) 144 | 145 | (define indexed 146 | \* return an indexed version of a list *\ 147 | {(list A) --> (list (number * A))} 148 | AS -> (indexed- 0 AS [])) 149 | 150 | (define reduce 151 | \* reduce a function over a list *\ 152 | {(A --> B --> B) --> B --> (list A) --> B} 153 | Fn B [A] -> (Fn A B) 154 | Fn B [A|AS] -> (reduce Fn (Fn A B) AS)) 155 | 156 | (define mapcon 157 | \* like map but concatenate the results *\ 158 | {(A --> (list B)) --> (list A) --> (list B)} 159 | _ [] -> [] 160 | Fn [A|AS] -> (append (Fn A) (mapcon Fn AS))) 161 | 162 | (define partition 163 | \* group the elements of a list breaking into sublists of size N *\ 164 | {number --> (list A) --> (list (list A))} 165 | _ [] -> [] 166 | N AS -> [(take N AS)|(partition N (drop N AS))]) 167 | 168 | (define partition-with 169 | \* partition into sublists every time a function returns a new value *\ 170 | {(Fn --> A --> B) --> (list A) --> (list (list A))} 171 | _ [] -> [] 172 | Fn [A|AS] -> (let Touchstone (Fn A) 173 | Head (cons A (take-while (/. X (= Touchstone (Fn X))) AS)) 174 | [Head|(partition-with Fn (drop (length Head) [A|AS]))])) 175 | 176 | (define unique- 177 | {(list A) --> (list A) --> (list A)} 178 | BS [] -> (reverse BS) 179 | BS [A|AS] -> (if (element? A BS) 180 | (unique- BS AS) 181 | (unique- [A|BS] AS))) 182 | 183 | (define unique 184 | \* remove all duplicate elements from a list *\ 185 | {(list A) --> (list A)} 186 | AS -> (unique- [] AS)) 187 | 188 | (define frequencies- 189 | {[(number * A)] --> (list A) --> [(number * A)]} 190 | ACC [] -> ACC 191 | ACC [A|AS] -> (frequencies- [(@p A (+ 1 (occurrences A AS)))|ACC] (remove A AS))) 192 | 193 | (define frequencies 194 | \* returns the number of occurences of each unique element in a list *\ 195 | {(list A) --> [(number * A)]} 196 | AS -> (frequencies- [] AS)) 197 | 198 | (define shuffle 199 | \* return a random permutation of a list *\ 200 | {(list A) --> (list A)} 201 | [] -> [] 202 | AS -> (let Index (+ 1 (random (length AS))) 203 | [(nth Index AS)|(shuffle (append (take (- Index 1) AS) 204 | (drop Index AS)))])) 205 | 206 | (define pick 207 | \* return a random element of a list *\ 208 | {(list A) --> A} 209 | AS -> (nth (+ 1 (random (length AS))) AS)) 210 | 211 | (define remove-first 212 | \* remove the first occurance of argument 1 in argument 2 *\ 213 | {A --> (list A) --> (list A)} 214 | _ [] -> [] 215 | X [A|AS] -> (if (= X A) AS [A|(remove-first X AS)])) 216 | 217 | (define interpose 218 | \* insert the first arg between every two elements of the second arg *\ 219 | {A --> (list A) --> (list A)} 220 | _ [] -> [] 221 | _ [A] -> [A] 222 | S [A|AS] -> [A S|(interpose S AS)]) 223 | 224 | (define subset? 225 | \* check if arg1 is a subset of arg2 *\ 226 | {(list A) --> (list A) --> boolean} 227 | [] _ -> true 228 | _ [] -> false 229 | [X|XS] YS -> (if (element? X YS) 230 | (subset? XS YS) 231 | false)) 232 | 233 | (define cartesian-product 234 | \* return the cartesian product of two lists *\ 235 | {(list A) --> (list B) --> (list (A * B))} 236 | [] _ -> [] 237 | [A|AS] BS -> (append (map (@p A) BS) (cartesian-product AS BS))) 238 | 239 | ) 240 | -------------------------------------------------------------------------------- /strings/auxiliary.shen: -------------------------------------------------------------------------------- 1 | \* Copyright (c) 22-03-12, Willi O Riha 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright notice, 10 | this list of conditions and the following disclaimer in the documentation 11 | and/or other materials provided with the distribution. 12 | 13 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 14 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 15 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 16 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 17 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 18 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 19 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 20 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 21 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 22 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | *\ 24 | 25 | (define != 26 | { A --> A --> boolean } 27 | X Y -> (not (= X Y))) 28 | 29 | (package aux [] 30 | 31 | (define maxL 32 | { (list number) --> number } 33 | [X] -> X 34 | [X | Y] -> (max' X (maxL Y)) 35 | [] -> (error "not defined!~%")) 36 | \* [] -> 1.7976931348623157e308 *\ 37 | 38 | (define minL 39 | { (list number) --> number } 40 | [X] -> X 41 | [X | Y] -> (min' X (minL Y)) 42 | [] -> (error "not defined!~%")) 43 | \* [] -> 0.22250738585072014e-307 *\ 44 | 45 | (define max' 46 | {number --> number --> number} 47 | M N -> (if (> M N) M N)) 48 | 49 | (define min' 50 | {number --> number --> number} 51 | M N -> (if (< M N) M N)) 52 | 53 | ) 54 | 55 | -------------------------------------------------------------------------------- /strings/macro-def.shen: -------------------------------------------------------------------------------- 1 | \* Copyright (c) 08-08-12, Willi O Riha 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright notice, 10 | this list of conditions and the following disclaimer in the documentation 11 | and/or other materials provided with the distribution. 12 | 13 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 14 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 15 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 16 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 17 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 18 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 19 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 20 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 21 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 22 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | *\ 24 | 25 | (defmacro let-macro 26 | [let [@p X Y] Z | W] 27 | -> (let Var (gensym (protect V)) 28 | [let Var Z | (subst [snd Var] Y (subst [fst Var] X W))])) 29 | 30 | (defmacro max-macro 31 | [max M N ] -> [aux.max' M N] 32 | [max | Ns] -> [aux.maxL (cf Ns)]) 33 | 34 | (defmacro min-macro 35 | [min M N ] -> [aux.min' M N] 36 | [min | Ns] -> [aux.minL (cf Ns)]) 37 | 38 | (defmacro gcd-macro 39 | [gcd M N ] -> [maths.gcd' M N] 40 | [gcd | Ns] -> [maths.gcdL (cf Ns)]) 41 | 42 | (defmacro lcm-macro 43 | [lcm | Ns] -> [maths.lcmL (cf Ns)]) 44 | 45 | (define cf 46 | [] -> [] 47 | [N | Ns] -> [cons N (cf Ns)]) 48 | 49 | (defmacro round-macro 50 | [round N] -> [maths.round0 N] 51 | [round N1 N2] -> [maths.round' N1 N2]) 52 | 53 | (declare sqrt [number --> number]) 54 | 55 | (defmacro string-list-macro 56 | string->list -> explode) 57 | 58 | (defmacro strlen-macro 59 | strlen -> string-length) 60 | 61 | (defmacro string->integer-macro 62 | [string->integer Str] -> [string-oct-hex-dec->decimal Str] 63 | [string->integer Str B] -> [radixB->decimal Str B]) 64 | 65 | -------------------------------------------------------------------------------- /strings/module.shen: -------------------------------------------------------------------------------- 1 | (register-module [[author: "Willi O Riha"] 2 | [load-fn: strings-load] 3 | [translate: "macro-def.shen" "auxiliary.shen" "ustring.shen" 4 | "str-lib.shen"]]) 5 | 6 | \* load native definitions of string functions for efficiency *\ 7 | (define strings-load-native 8 | _ _ -> true) 9 | 10 | (define strings-load 11 | _ -> (do 12 | (load/tc - "macro-def.shen") 13 | (load "auxiliary.shen") 14 | (load "ustring.shen") 15 | (load "str-lib.shen") 16 | (strings-load-native (language) (implementation)))) 17 | -------------------------------------------------------------------------------- /strings/str-lib.shen: -------------------------------------------------------------------------------- 1 | \* Copyright (c) 05-07-12, Mark Tarver, Eric Schulte, Willi O Riha 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright notice, 10 | this list of conditions and the following disclaimer in the documentation 11 | and/or other materials provided with the distribution. 12 | 13 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 14 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 15 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 16 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 17 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 18 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 19 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 20 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 21 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 22 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | *\ 24 | 25 | (package string [ustring? 26 | uppercase? lowercase? whitespace? digit? letter? 27 | ustr digit-string? substring? 28 | string-length list->string substring string-map 29 | <=str >str >=str radixB radixB->decimal] 31 | 32 | \* STRING PREDICATES *\ 33 | (define every? 34 | \* returns true iff predicate P applies to all unit strings of a string *\ 35 | { (string --> boolean) --> string --> boolean } 36 | P "" -> true 37 | P (@s S Str) -> (and (P S) (every? P Str))) 38 | 39 | (define any? 40 | \* returns true iff predicate P applies to at least one unit strings of a string *\ 41 | { (string --> boolean) --> string --> boolean } 42 | P "" -> false 43 | P (@s S Str) -> (if (P S) true (any? P Str))) 44 | 45 | (define digit-string? 46 | \* returns true iff string consists entirely of digitis *\ 47 | { string --> boolean } 48 | Str -> (every? digit? Str)) 49 | 50 | (define prefix? 51 | \* returns true iff 1st string is a prefix of 2nd *\ 52 | { string --> string --> boolean } 53 | "" _ -> true 54 | (@s S Str1) (@s S Str2) -> (prefix? Str1 Str2) 55 | _ _ -> false) 56 | 57 | (define prefix-length 58 | \* returns length of the longest common prefix of the two arguments *\ 59 | { string --> string --> number} 60 | Str1 Str2 -> (prefix-length-h Str1 Str2 0)) 61 | 62 | (define suffix-length 63 | \* returns length of the longest common suffix of the two arguments *\ 64 | { string --> string --> number} 65 | Str1 Str2 -> (prefix-length (string-reverse Str1) (string-reverse Str2))) 66 | 67 | (define prefix-length-h 68 | { string --> string --> number --> number} 69 | (@s S Str1) (@s S Str2) N -> (prefix-length-h Str1 Str2 (+ N 1)) 70 | _ _ N -> N) 71 | 72 | (define suffix? 73 | \* returns true iff 1st string is a suffix of 2nd *\ 74 | { string --> string --> boolean } 75 | Str1 Str2 -> (prefix? (string-reverse Str1) (string-reverse Str2))) 76 | 77 | (define substring? 78 | \* returns true iff 1st string is a substring of 2nd *\ 79 | { string --> string --> boolean } 80 | "" _ -> true 81 | _ "" -> false 82 | Str1 Str2 -> true where (prefix? Str1 Str2) 83 | Str1 (@s _ Str2) -> (substring? Str1 Str2)) 84 | 85 | (define string-map 86 | \* applies function F to each unit string of a string *\ 87 | {(string --> string) --> string --> string} 88 | F Str -> (map-h F Str "")) 89 | 90 | (define map-h 91 | {(string --> string) --> string --> string --> string} 92 | _ "" Result -> Result 93 | F (@s S Str) Result -> (map-h F Str (@s Result (F S)))) 94 | 95 | (define downcase 96 | \* returns string with all upper-case letters converted to lower case *\ 97 | { string --> string } 98 | Str -> (string-map (function ustring-downcase) Str)) 99 | 100 | (define upcase 101 | \* returns string with all lower-case letters converted to upper case *\ 102 | { string --> string } 103 | Str -> (string-map (function ustring-upcase) Str)) 104 | 105 | \* STRING COMPARISON *\ 106 | (define <=str 107 | { string --> string --> boolean } 108 | "" _ -> true 109 | _ "" -> false 110 | (@s S1 Str1) (@s S2 Str2) -> (if (= S1 S2) (<=str Str1 Str2) (=str 113 | { string --> string --> boolean } 114 | _ "" -> true 115 | "" _ -> false 116 | (@s S1 Str1) (@s S2 Str2) -> (if (= S1 S2) (>=str Str1 Str2) (>ustr S1 S2))) 117 | 118 | (define string --> boolean } 120 | Str1 Str2 -> (not (>=str Str1 Str2))) 121 | 122 | (define >str 123 | { string --> string --> boolean } 124 | Str1 Str2 -> (not (<=str Str1 Str2))) 125 | 126 | (define ref 127 | { number --> string --> string } 128 | N Str -> (pos Str N)) 129 | 130 | (define string-length 131 | \* returns the length of the string *\ 132 | { string --> number } 133 | Str -> (length-h Str 0)) 134 | 135 | (define length-h 136 | { string --> number --> number } 137 | "" Len -> Len 138 | (@s _ Str) Len -> (length-h Str (+ Len 1))) 139 | 140 | (define index 141 | \* returns the 'index' of Str1 in Str2, or -1 if not a substring *\ 142 | { string --> string --> number } 143 | Str1 Str2 -> (index-h Str1 Str2 0)) 144 | 145 | (define index-h 146 | { string --> string --> number --> number } 147 | Str1 Str2 N -> N where (prefix? Str1 Str2) 148 | _ "" _ -> -1 149 | Str1 (@s _ Str2) N -> (index-h Str1 Str2 (+ N 1))) 150 | 151 | (define index-last \* added 12-02-12 *\ 152 | \* returns the last 'index' of Str1 string in Str2, or -1 if not a substring *\ 153 | { string --> string --> number } 154 | Str1 Str2 -> (index-last-h Str1 Str2 -1 0)) 155 | 156 | (define index-last-h 157 | { string --> string --> number --> number --> number } 158 | Str1 Str2 Last N -> (index-last-h Str1 (tlstr Str2) N (+ N 1)) where (prefix? Str1 Str2) 159 | _ "" Last _ -> Last 160 | Str1 (@s _ Str2) Last N -> (index-last-h Str1 Str2 Last (+ N 1))) 161 | 162 | (define insert \* added 13-02-12 *\ 163 | \* inserts a string after the n-prefix *\ 164 | { number --> string --> string --> string } 165 | N Str1 Str2 -> (let Split(split N Str2) 166 | (@s (fst Split) Str1 (snd Split)))) 167 | 168 | (define split \* added 13-02-12 *\ 169 | \* splits a string into an n-prefix and the remaining suffix *\ 170 | { number --> string --> (string * string) } 171 | N Str -> (split-h N Str "")) 172 | 173 | (define split-h 174 | { number --> string --> string --> (string * string) } 175 | _ "" Result -> (@p Result "") 176 | N Str Result -> (@p Result Str) where (<= N 0) 177 | N (@s S Str) Result -> (split-h (- N 1) Str (@s Result S))) 178 | 179 | (define take 180 | \* returns the n-length prefix of string *\ 181 | { number --> string --> string } 182 | N Str -> (fst(split N Str))) 183 | 184 | (define drop 185 | \* drops the n-length prefix of string *\ 186 | { number --> string --> string } 187 | N Str -> (snd(split N Str))) 188 | 189 | (define take-right 190 | \* returns the n-length suffix of string *\ 191 | { number --> string --> string } 192 | N Str -> (drop (- (string-length Str) N) Str)) 193 | 194 | (define drop-right 195 | \* drops the n-length suffix of string *\ 196 | { number --> string --> string } 197 | N Str -> (take (- (string-length Str) N) Str)) 198 | 199 | (define substring 200 | \* returns substring Str[M..N] *\ 201 | { number --> number --> string --> string } 202 | M N Str -> (drop M (take (+ N 1) Str))) 203 | 204 | (define pad 205 | \* pads Str (on the left) to length N with unit strings S *\ 206 | { string --> number --> string --> string } 207 | S N Str -> (take-right N (@s (n-copy N S) Str))) 208 | 209 | (define count 210 | \* returns the no. of occurrences of Str1 in Str2 *\ 211 | { string --> string --> number } 212 | Str1 Str2 -> (count-h Str1 Str2 (string-length Str1) 0)) 213 | 214 | (define count-h 215 | { string --> string --> number --> number --> number } 216 | _ "" _ Count -> Count 217 | Str1 Str2 N Count -> (count-h Str1 (drop N Str2) N (+ Count 1)) 218 | where (prefix? Str1 Str2) 219 | Str1 (@s _ Str2) N Count -> (count-h Str1 Str2 N Count)) 220 | 221 | (define replace-all 222 | \* replaces all occurrences of Str2 with Str1 in Str3 *\ 223 | { string --> string --> string --> string } 224 | _ "" _ -> (error "empty substring in 'replace-all'!~%") 225 | Str1 Str2 Str3 -> (replace-all-h Str1 Str2 Str3 (string-length Str2) "")) 226 | 227 | (define replace-all-h 228 | { string --> string --> string --> number --> string --> string } 229 | _ _ "" _ Result -> Result 230 | Str1 Str2 Str3 N Result -> (replace-all-h Str1 Str2 (drop N Str3) N (cn Result Str1)) 231 | where (prefix? Str2 Str3) 232 | Str1 Str2 (@s S Str) N Result -> (replace-all-h Str1 Str2 Str N (cn Result S))) 233 | 234 | (define replace 235 | \* replaces the I-th occurrence of Str2 with Str1 in Str3 *\ 236 | { string --> string --> number --> string --> string } 237 | _ "" _ _ -> (error "empty substring in 'replace'!~%") 238 | Str1 Str2 I Str3 -> (replace-h Str1 Str2 Str3 I "")) 239 | 240 | (define replace-h 241 | { string --> string --> string --> number --> string --> string} 242 | _ _ "" _ Result -> Result 243 | Str1 Str2 Str3 1 Result -> (@s Result Str1 (drop (string-length Str2) Str3)) 244 | where (prefix? Str2 Str3) 245 | Str1 Str2 Str3 I Result -> (replace-h Str1 Str2 (tlstr Str3) (- I 1) (cn Result (hdstr Str3))) 246 | where (prefix? Str2 Str3) 247 | Str1 Str2 (@s S Str) I Result -> (replace-h Str1 Str2 Str I (cn Result S))) 248 | 249 | (define delete-all 250 | \* deletes all occurrences of Str1 in Str2 *\ 251 | { string --> string --> string } 252 | "" Str2 -> Str2 253 | Str1 Str2 -> (replace-all "" Str1 Str2)) 254 | 255 | (define delete-substring 256 | \* deletes substring Str[M..N] *\ 257 | { number --> number --> string --> string } 258 | M N Str -> Str where (> M N) 259 | M N Str -> (cn (take M Str)(drop (+ N 1) Str))) 260 | 261 | (define n-copy 262 | \* makes n copies of a string *\ 263 | { number --> string --> string } 264 | N Str -> (n-copy-h N Str "")) 265 | 266 | (define n-copy-h 267 | { number --> string --> string --> string } 268 | N Str Copy -> Copy where (<= N 0) 269 | N Str Copy -> (n-copy-h(- N 1) Str (@s Copy Str))) 270 | 271 | (define trim-left 272 | \* drops the longest prefix whose unit strings all satisfy predicate P *\ 273 | { (string --> boolean) --> string --> string } 274 | _ "" -> "" 275 | P (@s S Str) -> (@s S Str) where (not (P S)) 276 | P (@s _ Str) -> (trim-left P Str)) 277 | 278 | (define trim-right 279 | { (string --> boolean) --> string --> string } 280 | P Str -> (string-reverse (trim-left P (string-reverse Str)))) 281 | 282 | (define trim 283 | { (string --> boolean) --> string --> string } 284 | P Str -> (string-reverse (trim-left P (string-reverse (trim-left P Str))))) 285 | 286 | (define string-reverse 287 | \* reverses a string *\ 288 | {string --> string} 289 | Str -> (reverse-h Str "")) 290 | 291 | (define reverse-h 292 | {string --> string --> string} 293 | "" Rev -> Rev 294 | (@s S Str) Rev -> (reverse-h Str (@s S Rev))) 295 | 296 | (define tokenise 297 | { (string --> boolean) --> string --> (list string)} 298 | F Str -> (tokenise-h F Str "" [])) 299 | 300 | (define tokenise-h 301 | { (string --> boolean) --> string --> string --> (list string) --> (list string)} 302 | _ "" Str L -> (reverse [Str | L]) 303 | F (@s S1 Str) S2 L -> (tokenise-h F Str "" [S2 | L]) where (F S1) 304 | F (@s S1 Str) S2 L -> (tokenise-h F Str (@s S2 S1) L)) 305 | 306 | (define interpose 307 | \* inserts the first arg between every two elements of the second arg *\ 308 | { string --> string --> string } 309 | J Str -> (interpose-h J Str "")) 310 | 311 | (define interpose-h 312 | { string --> string --> string --> string } 313 | _ "" Result -> Result 314 | _ Str Result -> (@s Result Str) where (ustring? Str) 315 | J (@s S Str) Result -> (interpose-h J Str (@s Result S J))) 316 | 317 | (define join 318 | \* inserts the first arg between every two elements of the second arg *\ 319 | { string --> (list string) --> string} 320 | J StrL -> (join-h J StrL "")) 321 | 322 | (define join-h 323 | { string --> (list string) --> string --> string} 324 | _ [] Result -> Result 325 | _ [Str] Result -> (@s Result Str) 326 | J [Str | StrL] Result -> (join-h J StrL (@s Result Str J))) 327 | 328 | (define filter 329 | { (string --> boolean) --> string --> string } 330 | P Str -> (filter-h P Str "")) 331 | 332 | (define filter-h 333 | { (string --> boolean) --> string --> string --> string } 334 | P "" Result -> Result 335 | P (@s S Str) Result -> (if (P S) 336 | (filter-h P Str (@s Result S)) 337 | (filter-h P Str Result))) 338 | 339 | (define count-ustrings 340 | {(string --> boolean) --> string --> number } 341 | P Str -> (reduce (/. S N (if (P S) (+ N 1) N)) 0 Str)) 342 | 343 | (define reduce \* foldr *\ \* not tail recursive *\ 344 | \* right-left reduction of a function over a string *\ 345 | {(string --> B --> B) --> B --> string --> B} 346 | F B "" -> B 347 | F B (@s S Str) -> (F S (reduce F B Str))) 348 | 349 | (define reduce' \* tail recursive *\ 350 | \* right-left reduction of a function over a string *\ 351 | {(string --> B --> B) --> B --> string --> B} 352 | F B Str -> (reduce-h F B (string-reverse Str) B)) 353 | 354 | (define reduce-h 355 | {(string --> B --> B) --> B --> string --> B --> B} 356 | F B "" Result -> Result 357 | F B (@s S Str) Result -> (reduce-h F B Str (F S Result))) 358 | 359 | (define foldl 360 | \* left-right reduction of a function over a string *\ 361 | {(string --> B --> B) --> B --> string --> B} 362 | F B "" -> B 363 | F B (@s S Str) -> (foldl F (F S B) Str)) 364 | 365 | (define list->string 366 | { (list string) --> string } 367 | L -> (list->str-h L "")) 368 | 369 | (define list->str-h 370 | { (list string) --> string --> string } 371 | [] Str -> Str 372 | [S | L] Str -> (list->str-h L (@s Str S))) 373 | 374 | \* NUMBER CONVERSIONS *\ 375 | 376 | (define >number 377 | { string --> number } 378 | Str -> (let Ex (index "e" Str) 379 | (if (< Ex 0) 380 | (->decimal Str) 381 | (let Tl (drop (+ Ex 1) Str) 382 | Exp (exptL Tl) 383 | ScaleF (pow10 Exp) 384 | Y (take Ex Str) 385 | (* (->decimal Y) ScaleF))))) 386 | 387 | (define ->decimal 388 | { string --> number } 389 | "" -> (error "empty string~%") 390 | Str -> (let Pt (index "." Str) 391 | (if (< Pt 0) 392 | (str->int Str) 393 | (let Hd (simplify(take Pt Str)) 394 | Tl (drop (+ Pt 1) Str) 395 | Sgn (take 1 Hd) 396 | IntPart (str->uint (drop 1 Hd)) 397 | FracPart (->fraction Tl) 398 | Res (+ IntPart FracPart) 399 | (if (= Sgn "+") Res (- 0 Res)))))) 400 | 401 | (define exptL 402 | { string --> number } 403 | "" -> (error "exponent missing!~%") 404 | "-" -> (error "exponent missing!~%") 405 | (@s "-" Str) -> (- 0 (str->uint Str)) 406 | (@s S _) -> (error "illegal character '~A' in exponent~%" S) where (not (digit? S)) 407 | Str -> (str->uint Str)) 408 | 409 | (define ->fraction 410 | { string --> number } 411 | "" -> (error "fractional part missing!~%") 412 | Str -> (->fraction-h Str)) 413 | 414 | \* accumulates fraction from string implicitly reversing it *\ 415 | (define ->fraction-h 416 | { string --> number } 417 | "" -> 0 418 | (@s S Str) -> (let D (str->digit S) 419 | (if (< D 0) 420 | (error "illegal character '~A' in number~%" S) 421 | (/ (+ (->fraction-h Str) D) 10)))) 422 | 423 | (define str->int 424 | { string --> number } 425 | "" -> (error "not a number!~%") 426 | (@s "-" Str) -> (- 0 (str->int Str)) 427 | (@s "+" Str) -> (str->int Str) 428 | Str -> (str->uint Str)) 429 | 430 | (define str->uint 431 | { string --> number } 432 | Str -> (str->uint-h Str 0)) 433 | 434 | (define str->uint-h 435 | { string --> number --> number } 436 | "" N -> N 437 | (@s S Str) N -> (let D (str->digit S) 438 | (if (< D 0) (error "illegal digit '~A' in decimal number~%" S) 439 | (str->uint-h Str(+ (* N 10) D ))))) 440 | 441 | (define str->digit 442 | { string --> number } 443 | Str -> (let D (string->n Str) 444 | (if (ustring-inrange? D 48 57) (- D 48) -1))) 445 | 446 | (define trim0s 447 | { string --> string } 448 | (@s "0" Str) -> (trim0s Str) 449 | Str -> Str) 450 | 451 | (define simplify 452 | { string --> string } 453 | (@s "-" "-" Str) -> (simplify Str) 454 | (@s "+" "-" Str) -> (simplify (@s "-" Str)) 455 | (@s "-" "+" Str) -> (simplify (@s "-" Str)) 456 | (@s "+" Str) -> (simplify Str) 457 | (@s "-" Str) -> (@s "-" (trim0s Str)) 458 | Str -> (@s "+" (trim0s Str))) 459 | 460 | \* RADIX CONVERSION *\ 461 | 462 | (define radixBdigit->decimal \* auxiliary *\ 463 | \* S is a 'digit' occurring in a radix-B number, 464 | if S is a bona fide digit then the fn returns the decimal value of S, 465 | where "0" -> 0 "a" or "A" -> 10, "b" -> 11 etc 466 | if S is an illegal digit, e.g. "3" in a binary number, -1 is returned *\ 467 | { string --> number --> number } 468 | S B -> (let D (adjust(string->n (ustring-downcase S))) 469 | (if (and (<= 0 D) (< D B)) D -1))) 470 | 471 | (define adjust \* auxiliary *\ 472 | { number --> number } 473 | N -> (- N 48) where (< N 58) 474 | N -> (- N 87)) 475 | 476 | (define digit->str \* auxiliary *\ 477 | { number --> string } 478 | N -> (n->string (+ N 48)) where (< N 10) 479 | N -> (n->string (+ N 87))) 480 | 481 | (define radixB->decimal 482 | \* if Str represents an integer in radix-B number system the decimal equivalent is returned 483 | otherwise an error message is displayed *\ 484 | { string --> number --> number } 485 | _ B -> (error "radix must be greater than '1'~%") where (< B 2) 486 | (@s "0" Str) 16 -> (hex' Str) 487 | Str B -> (radixB->decimal-h Str B 0)) 488 | 489 | (define hex' \*auxiliary *\ 490 | { string --> number } 491 | (@s "x" Str) -> (radixB->decimal-h Str 16 0) 492 | Str -> (radixB->decimal-h Str 16 0)) 493 | 494 | (define radixB->decimal-h 495 | { string --> number --> number --> number } 496 | "" _ N -> N 497 | (@s S Str) B N -> (let D (radixBdigit->decimal S B) 498 | (if (< D 0) 499 | (error "illegal digit '~A' in radix '~A' integer~%" S B) 500 | (radixB->decimal-h Str B(+ (* N B) D ))))) 501 | 502 | (define oct-hex->decimal \* auxiliary *\ 503 | { string --> number } 504 | (@s "x" Str) -> (radixB->decimal-h Str 16 0) 505 | Str -> (radixB->decimal-h Str 8 0)) 506 | 507 | (define oct-hex-dec->decimal 508 | \* converts to decimal, octal or hex *\ 509 | { string --> number } 510 | (@s "0" Str) -> (oct-hex->decimal Str) 511 | Str -> (radixB->decimal-h Str 10 0)) 512 | 513 | (define decimal->radixB 514 | \* converts a decimal integer to radix-B *\ 515 | { number --> number --> string } 516 | _ B -> (error "radix must be greater than 1~%") where (<= B 1) 517 | X B -> (decimal->radixB-h (abs X) B "")) 518 | 519 | (define decimal->radixB-h 520 | { number --> number --> string --> string} 521 | 0 B S -> S 522 | X B S -> (let DivMod (/-pos X B) 523 | (decimal->radixB-h (fst DivMod) B (@s (digit->str (snd DivMod)) S)))) 524 | 525 | (define radixB->radixC 526 | \* converts from radix-B to radix-C *\ 527 | { string --> number --> number --> string } 528 | Str B C -> (decimal->radixB (radixB->decimal Str B) C)) 529 | 530 | \* auxiliary *\ 531 | (define pow10+ 532 | { number --> number } 533 | 0 -> 1 534 | N -> (* (pow10+ (- N 1)) 10)) 535 | 536 | \* auxiliary *\ 537 | (define pow10 538 | {number --> number } 539 | N -> (pow10+ N) where (>= N 0) 540 | N -> (/ 1 (pow10+ (- 0 N)))) 541 | 542 | \* from maths-lib *\ 543 | 544 | (define abs 545 | { number --> number } 546 | X -> (if (>= X 0) X (- 0 X))) 547 | 548 | (define /-pos 549 | { number --> number --> (number * number) } 550 | _ 0 -> (error "division by 0!~%") 551 | A B -> (@p 0 A) where (> B A) 552 | _ B -> (error "divisor must be an integer!~%") where (not(integer? B)) 553 | A B -> (let Pow2 (pow-2div B A 1) 554 | (div-w A (* Pow2 B) Pow2 0))) 555 | 556 | (define div-w 557 | { number --> number --> number --> number --> (number * number) } 558 | A B 1 Q -> (if (<= B A) (@p (+ Q 1) (- A B)) (@p Q A)) 559 | A B P Q -> (if (<= B A) (div-w (- A B) (/ B 2) (/ P 2) (+ Q P)) 560 | (div-w A (/ B 2) (/ P 2) Q))) 561 | 562 | (define pow-2div 563 | \* returns the smallest power of 2, s.t. B*Pow2 > A *\ 564 | { number --> number --> number --> number } 565 | B A Pow2 -> (if (<= B A) (pow-2div (* B 2) A (* Pow2 2)) Pow2)) 566 | 567 | ) -------------------------------------------------------------------------------- /strings/strings.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vasil-sd/shen-libs/6512ba4fad752158470a92766b55e30591eae12f/strings/strings.pdf -------------------------------------------------------------------------------- /strings/ustring.shen: -------------------------------------------------------------------------------- 1 | \* Copyright (c) 16-02-12, Willi O Riha 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright notice, 10 | this list of conditions and the following disclaimer in the documentation 11 | and/or other materials provided with the distribution. 12 | 13 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 14 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 15 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 16 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 17 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 18 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 19 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 20 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 21 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 22 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | *\ 24 | 25 | (define ustring? 26 | \* returns true iff argument is a unit string *\ 27 | { string --> boolean } 28 | (@s _ "") -> true 29 | _ -> false) 30 | 31 | (package string [whitespace? digit? letter? ustr <=ustr >=ustr] 32 | 33 | \* PREDICATES *\ 34 | (define digit? 35 | \* returns true iff argument is one of "0", "1", "9" *\ 36 | { string --> boolean } 37 | S -> (ustring-inrange? (string->n S) 48 57)) 38 | 39 | (define letter? 40 | \* returns true iff argument is a letter *\ 41 | { string --> boolean } 42 | S -> (or (lowercase? S) (uppercase? S))) 43 | 44 | (define uppercase? 45 | \* returns true iff argument is an upper-case letter *\ 46 | { string --> boolean } 47 | S -> (ustring-inrange? (string->n S) 65 90)) 48 | 49 | (define lowercase? 50 | \* returns true iff argument is a lower-case letter *\ 51 | { string --> boolean } 52 | S -> (ustring-inrange? (string->n S) 97 122)) 53 | 54 | (define whitespace? 55 | \* returns true iff argument is a 'white space' *\ 56 | { string --> boolean } 57 | S -> (element? S ["c#9;" "c#10;" "c#11;" "c#12;" "c#13;" " "])) 58 | 59 | (define ustring-inrange? \* auxiliary *\ 60 | { number --> number --> number --> boolean } 61 | N Lb Ub -> (and (>= N Lb) (<= N Ub))) 62 | 63 | \* FUNCTIONS *\ 64 | (define ustring-upcase 65 | { string --> string } 66 | S -> (n->string (- (string->n S) 32)) where (lowercase? S) 67 | S -> S) 68 | 69 | (define ustring-downcase 70 | { string --> string } 71 | S -> (n->string (+ (string->n S) 32)) where (uppercase? S) 72 | S -> S) 73 | 74 | \* COMPARISON *\ 75 | (define string --> boolean } 77 | S1 S2 -> (< (string->n S1) (string->n S2))) 78 | 79 | (define <=ustr 80 | { string --> string --> boolean } 81 | S1 S2 -> (<= (string->n S1) (string->n S2))) 82 | 83 | (define >ustr 84 | { string --> string --> boolean } 85 | S1 S2 -> (> (string->n S1) (string->n S2))) 86 | 87 | (define >=ustr 88 | { string --> string --> boolean } 89 | S1 S2 -> (>= (string->n S1) (string->n S2))) 90 | 91 | ) 92 | 93 | -------------------------------------------------------------------------------- /utils/defpackage.shen: -------------------------------------------------------------------------------- 1 | \* Copyright 2010-2011 Vasil S. Diadov 2 | 3 | defpackage.shen is free software: you can redistribute it and/or modify 4 | it under the terms of the GNU General Public License as published by 5 | the Free Software Foundation, either version 3 of the License, or 6 | (at your option) any later version. 7 | 8 | defpackage.shen is distributed in the hope that it will be useful, 9 | but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | GNU General Public License for more details. 12 | 13 | You should have received a copy of the GNU General Public License 14 | along with package.shen. 15 | If not, see . 16 | 17 | 18 | Description 19 | =========== 20 | defpackage.shen contains macro for package managment for Shen. 21 | Package management allows importing/exporting symbols across packages, to 22 | introducing package aliases and so on. 23 | 24 | Usage: 25 | 26 | (defpackage Name ListOfExportImportSymbols | Code) 27 | 28 | where Name is package name (prefix for all symbols in package, except 29 | symbols listed in ListOfExportImportSymbols and symbols 30 | shielded by (not-in-package ...)) 31 | defpackage may include another defpackage in Code. 32 | 33 | Example: 34 | 35 | (defpackage mypkg- [a b] 36 | [a b c]) 37 | 38 | result: [a b mypkg-c] 39 | 40 | 41 | 42 | (subpackage Name ListOfExportImportSymbols | Code) 43 | 44 | where Name is subpackage name (which is concatenated with toplevel package 45 | name to form new symbols prefix) and ListOfExportImportSymbols is added 46 | to exceptions list inherited from upper package or subpackage. 47 | 48 | Example: 49 | 50 | (defpackage mypkg- [a b] 51 | (subpackage subpkg- [c] 52 | [a b c d])) 53 | 54 | result: [a b c mypkg-subpkg-d] 55 | 56 | 57 | (from-package Name Symbols | Code) 58 | 59 | where Name is name or alias (within scope of (package-alias ...) form) 60 | of package to which Symbols belong, and Symbols are symbol names which will 61 | be prefixed by given package name. 62 | 63 | Example: 64 | (defpackage mypkg- [c] 65 | (from-package pkg1- [a b] 66 | [a b c d])) 67 | 68 | result: [pkg1-a pkg1-b c mypkg-d] 69 | 70 | (not-in-package | Code) 71 | 72 | blocks symbol renaming rules within its scope. 73 | 74 | Example: 75 | 76 | (defpackage mypkg- [c] 77 | (subpackage pkg1- [d] 78 | [c d e f] 79 | (not-in-package [c d e f]))) 80 | 81 | result: [c d mypkg-pkg1-e mypkg-pkg1-f] 82 | [c d e f] 83 | 84 | 85 | (package-alias [ Name1 Alias1 86 | Name2 Alias2...] | Code) 87 | 88 | introduces aliases for packages. Every package alias is treated as package name. 89 | 90 | Example: 91 | 92 | (defpackage mypkg- [a b] 93 | (package-alias [big-package-name- bpn- 94 | very-big-package-name- vbpn-] 95 | [bpn-a vbpn-b] 96 | 97 | (from-package vbpn- [q w e] 98 | [q w e r t y]))) 99 | 100 | result: [big-package-name-a very-big-package-name-b] 101 | [very-big-package-name-q very-big-package-name-w 102 | very-big-package-name-e mypkg-r mypkg-t mypkg-y] 103 | 104 | 105 | End of description. 106 | =================== 107 | *\ 108 | 109 | 110 | (package defpackage- [ defpackage subpackage from-package 111 | not-in-package package-alias 112 | load-in-package register-defpackage-macro] 113 | 114 | (define register-defpackage-macro 115 | Symbol F -> (set *package-macros* (adjoin [Symbol F] (value *package-macros*)))) 116 | 117 | (define if-not-fail 118 | Result Cont -> (Cont Result) where (not (= Result (fail))) 119 | Fail _ -> Fail) 120 | 121 | (define string-remove-prefix 122 | "" S -> S 123 | (@s C S1) (@s C S2) -> (string-remove-prefix S1 S2) 124 | _ _ -> (fail)) 125 | 126 | (define symbol-remove-prefix 127 | Pr Sym -> (if-not-fail 128 | (string-remove-prefix (str Pr) (str Sym)) 129 | (function intern))) 130 | 131 | (define process-alias 132 | [] Name -> Name 133 | [[Name Alias] | _] Alias -> Name 134 | [ X | Y] Alias -> (process-alias Y Alias)) 135 | 136 | (define import-symbol 137 | [] Sym -> (fail) 138 | [[_] | Rest] Sym -> (import-symbol Rest Sym) 139 | [[Pkg Sym | _] | _] Sym -> (concat Pkg Sym) 140 | [[Pkg X | Y] | Z] Sym -> (import-symbol [[Pkg | Y] | Z] Sym)) 141 | 142 | (define rename-symbol 143 | Name Alias Sym -> 144 | (if-not-fail (symbol-remove-prefix Alias Sym) (concat Name))) 145 | 146 | (define packaged-symbol 147 | [] Sym -> (fail) 148 | [[Name Alias] | Rest] Sym <- (rename-symbol Name Alias Sym) 149 | [_ | Rest] Sym -> (packaged-symbol Rest Sym)) 150 | 151 | (define process-symbol 152 | _ _ Imported _ Sym <- (import-symbol Imported Sym) 153 | _ _ _ Aliases Sym <- (packaged-symbol Aliases Sym) 154 | _ Exceptions _ _ Sym -> Sym where (element? Sym Exceptions) 155 | Prefix _ _ _ Sym -> (concat Prefix Sym) where (symbol? Prefix) 156 | _ _ _ _ Sym -> Sym) 157 | 158 | (define find-package-macro 159 | Sym -> (let Macro (assoc Sym (value *package-macros*)) 160 | (if (empty? Macro) 161 | (fail) 162 | (head (tail Macro))))) 163 | 164 | (define apply-package-macro 165 | Prefix Exceptions Imported Aliases Sym Code -> 166 | (if-not-fail 167 | (find-package-macro Sym) 168 | (/. F (F Prefix Exceptions Imported Aliases Code)))) 169 | 170 | (define insert-macroexpanded-code 171 | [append Code] Program -> (append Code Program) 172 | [cons Code] Program -> (cons Code Program)) 173 | 174 | (define process-package 175 | Prefix Exceptions Imported Aliases [[Symbol | Body] | Code] <- 176 | (if-not-fail 177 | (apply-package-macro Prefix Exceptions Imported Aliases Symbol Body) 178 | (/. Result 179 | (insert-macroexpanded-code 180 | Result 181 | (process-package Prefix Exceptions Imported Aliases Code)))) 182 | 183 | Prefix Exceptions Imported Aliases [X | Y]-> 184 | [(process-package Prefix Exceptions Imported Aliases X) | 185 | (process-package Prefix Exceptions Imported Aliases Y) ] 186 | 187 | Prefix Exceptions Imported Aliases Sym -> 188 | (process-symbol Prefix Exceptions Imported Aliases Sym) 189 | where (and 190 | (symbol? Sym) 191 | (not 192 | (or 193 | (shen-sysfunc? Sym) 194 | (shen-prefix? (explode shen-) Sym) 195 | (shen-singleunderline? Sym) 196 | (shen-doubleunderline? Sym)))) 197 | 198 | _ _ _ _ X -> X) 199 | 200 | 201 | (define defpackage-macro-not-in-package 202 | _ _ _ _ Code -> [append (process-package [] [] [] [] Code)]) 203 | 204 | (define defpackage-macro-subpackage 205 | Prefix Exceptions Imported Aliases [Name Symbols | Code]-> 206 | [append (process-package 207 | (concat Prefix Name) 208 | (append Exceptions (eval-without-macros Symbols)) 209 | Imported 210 | Aliases 211 | Code)]) 212 | 213 | (define defpackage-macro-from-package 214 | Prefix Exceptions Imported Aliases [Name Symbols | Code]-> 215 | [append 216 | (process-package 217 | Prefix 218 | Exceptions 219 | [[(process-alias Aliases Name) | 220 | (eval-without-macros Symbols)] | 221 | Imported] 222 | Aliases 223 | Code)]) 224 | 225 | (define compose-names-and-aliases 226 | [] Acc -> Acc 227 | [X Y | Rest] Acc -> [[X Y] | (compose-names-and-aliases Rest Acc)]) 228 | 229 | (define defpackage-macro-package-alias 230 | Prefix Exceptions Imported Aliases [NamesAndAliases | Code]-> 231 | [append 232 | (process-package 233 | Prefix 234 | Exceptions 235 | Imported 236 | (compose-names-and-aliases 237 | (eval-without-macros NamesAndAliases) 238 | Aliases) 239 | Code)]) 240 | 241 | (set *package-macros* [ 242 | [not-in-package (function defpackage-macro-not-in-package)] 243 | [subpackage (function defpackage-macro-subpackage)] 244 | [from-package (function defpackage-macro-from-package)] 245 | [package-alias (function defpackage-macro-package-alias)] 246 | ]) 247 | 248 | (defmacro package-macro 249 | [defpackage Name Exceptions | Code] -> 250 | [package null [] | 251 | (process-package 252 | Name 253 | (eval-without-macros Exceptions) 254 | [] 255 | [] 256 | Code)] 257 | 258 | [defpackage null [] | Code] -> 259 | [package null [] | 260 | (process-package [] [] [] [] Code)]) 261 | 262 | ) \* end of package defpackage- *\ 263 | -------------------------------------------------------------------------------- /vectors-mt/module.shen: -------------------------------------------------------------------------------- 1 | (register-module [[name: vectors-mt] 2 | [author: "Mark Tarver"] 3 | [load: "vectors.shen"]]) 4 | -------------------------------------------------------------------------------- /vectors-mt/vectors.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vasil-sd/shen-libs/6512ba4fad752158470a92766b55e30591eae12f/vectors-mt/vectors.pdf -------------------------------------------------------------------------------- /vectors-mt/vectors.shen: -------------------------------------------------------------------------------- 1 | (package vector [vector-shell vector-copy vector-extend vector-map vector-map! 2 | vector-tail vector-list vector->string cnvector string->vector 3 | vector->list list->vector vector-prefix? vector-suffix? 4 | vector-every? vector-any? vector-subst vector-reverse 5 | vector-dense vector-== vector-index-defined? 6 | vector-index-undefined? 7 | file->vectorstring file->vectornum vector-append] 8 | 9 | (define vector-shell 10 | {(vector A) --> (vector B)} 11 | V -> (vector (limit V))) 12 | 13 | (define vector-append 14 | {(vector A) --> (vector A) --> (vector A)} 15 | V1 V2 -> (list->vector (append (vector->list V1) (vector->list V2)))) 16 | 17 | (define vector-copy 18 | {(vector A) --> (vector A)} 19 | Vector -> (vector-extend Vector 0)) 20 | 21 | (define vector-dense 22 | {(vector A) --> (vector A)} 23 | Vector -> (list->vector (vector->list Vector))) 24 | 25 | (define vector-subst 26 | {A --> A --> (vector A) --> (vector A)} 27 | X Y V -> (vector-subst' X Y V (limit V))) 28 | 29 | (define vector-subst' 30 | {A --> A --> (vector A) --> number --> (vector A)} 31 | _ _ V 0 -> V 32 | X Y V N -> (vector-subst' X Y (trap-error (let VN (<-vector V N) 33 | (if (= VN Y) 34 | (vector-> V N X) 35 | V)) (/. E V)) (- N 1))) 36 | 37 | (define vector-extend 38 | {(vector A) --> number --> (vector A)} 39 | Vector N -> (vector-extend' Vector (vector (+ (limit Vector) N)) (limit Vector) 1)) 40 | 41 | (define vector-extend' 42 | {(vector A) --> (vector A) --> number --> number --> (vector A)} 43 | Vector Copy N N -> (copy-to-vector Vector Copy N) 44 | Vector Copy Limit N -> (vector-extend' Vector 45 | (copy-to-vector Vector Copy N) 46 | Limit 47 | (+ N 1))) 48 | 49 | (define copy-to-vector 50 | {(vector A) --> (vector A) --> number --> (vector A)} 51 | Vector Copy N -> (trap-error (vector-> Copy N (<-vector Vector N)) (/. E Copy))) 52 | 53 | (define vector-map 54 | {(A --> B) --> (vector A) --> (vector B)} 55 | F Vector -> (vector-map' F Vector (vector-shell Vector) (limit Vector) 1)) 56 | 57 | (define vector-map' 58 | {(A --> B) --> (vector A) --> (vector B) --> number --> number --> (vector B)} 59 | F Vector FVector N N -> (copy-to-FVector F Vector FVector N) 60 | F Vector FVector Limit N -> (vector-map' F Vector 61 | (copy-to-FVector F Vector FVector N) 62 | Limit 63 | (+ N 1))) 64 | 65 | (define copy-to-FVector 66 | {(A --> B) --> (vector A) --> (vector B) --> number --> (vector B)} 67 | F Vector FVector N -> (trap-error (vector-> FVector N (F (<-vector Vector N))) (/. E FVector))) 68 | 69 | (define vector-map! 70 | {(A --> A) --> (vector A) --> (vector A)} 71 | F Vector -> (vector-map!' F Vector (limit Vector) 1)) 72 | 73 | (define vector-map!' 74 | {(A --> A) --> (vector A) --> number --> number --> (vector A)} 75 | F Vector N N -> (copy-to-FVector F Vector Vector N) 76 | F Vector Limit N -> (vector-map!' F (copy-to-FVector F Vector Vector N) Limit (+ N 1))) 77 | 78 | (define vector->list 79 | {(vector A) --> (list A)} 80 | Vector -> (vector->list' Vector (limit Vector) [])) 81 | 82 | (define vector->list' 83 | {(vector A) --> number --> (list A) --> (list A)} 84 | Vector 0 L -> L 85 | Vector N L -> (vector->list' Vector 86 | (- N 1) 87 | (trap-error [(<-vector Vector N) | L] (/. E L)))) 88 | 89 | (define list->vector 90 | {(list A) --> (vector A)} 91 | L -> (list->vector' L (vector (length L)) 1)) 92 | 93 | (define list->vector' 94 | {(list A) --> (vector A) --> number --> (vector A)} 95 | [] Vector _ -> Vector 96 | [X | Y] Vector N -> (list->vector' Y (vector-> Vector N X) (+ N 1))) 97 | 98 | (define vector-== 99 | {(vector A) --> (vector B) --> boolean} 100 | V1 V2 -> (== (vector->list V1) (vector->list V2))) 101 | 102 | (define vector->string 103 | {(vector A) --> string} 104 | Vector -> (vector->string' Vector 1 (limit Vector) "")) 105 | 106 | (define vector->string' 107 | {(vector A) --> number --> number --> string --> string} 108 | Vector N N String -> (cnvector String Vector N) 109 | Vector N Limit String -> (vector->string' Vector 110 | (+ N 1) 111 | Limit 112 | (cnvector String Vector N))) 113 | 114 | (define cnvector 115 | {string --> (vector A) --> number --> string} 116 | String Vector N -> (trap-error (let X (<-vector Vector N) 117 | VString (cases (symbol? X) (str X) 118 | (boolean? X) (str X) 119 | (number? X) (str X) 120 | true (make-string "~A" X)) 121 | (cn String VString)) (/. E String))) 122 | 123 | (define string->vector 124 | {string --> (vector string)} 125 | "" -> <> 126 | (@s S Ss) -> (@v S (string->vector Ss))) 127 | 128 | (define vector-prefix? 129 | {(vector A) --> (vector B) --> boolean} 130 | V1 V2 -> (let L1 (limit V1) 131 | L2 (limit V2) 132 | (if (> L1 L2) 133 | false 134 | (vector-prefix'? V1 V2 L1))) ) 135 | 136 | (define vector-prefix'? 137 | {(vector A) --> (vector B) --> number --> boolean} 138 | _ _ 0 -> true 139 | V1 V2 N -> (vector-prefix'? V1 V2 (- N 1)) 140 | where (cases (vector-index-undefined? V1 N) (vector-index-undefined? V2 N) 141 | (vector-index-undefined? V2 N) false 142 | true (== (<-vector V1 N) (<-vector V2 N))) 143 | _ _ _ -> false) 144 | 145 | (define vector-index-undefined? 146 | {(vector A) --> number --> boolean} 147 | V N -> (trap-error (do (<-vector V N) false) (/. E true))) 148 | 149 | (define vector-index-defined? 150 | {(vector A) --> number --> boolean} 151 | V N -> (trap-error (do (<-vector V N) true) (/. E false))) 152 | 153 | (define vector-suffix? 154 | {(vector A) --> (vector B) --> boolean} 155 | V1 V2 -> (let L1 (limit V1) 156 | L2 (limit V2) 157 | (if (> L2 L1) 158 | (vector-suffix'? V1 V2 L1 L2) 159 | false)) ) 160 | 161 | (define vector-suffix'? 162 | {(vector A) --> (vector B) --> number --> number --> boolean} 163 | _ _ 0 _ -> true 164 | V1 V2 L1 L2 -> (vector-suffix'? V1 V2 (- L1 1) (- L2 1)) 165 | where (trap-error (== (<-vector V1 L1) (<-vector V2 L2)) (/. E false)) 166 | _ _ _ _ -> false) 167 | 168 | (define vector-every? 169 | {(A --> boolean) --> (vector A) --> boolean} 170 | F V -> (vector-every'? F V (limit V))) 171 | 172 | (define vector-every'? 173 | {(A --> boolean) --> (vector A) --> number --> boolean} 174 | _ _ 0 -> true 175 | F V N -> (vector-every'? F V (- N 1)) where (trap-error (F (<-vector V N)) (/. E true)) 176 | _ _ _ -> false) 177 | 178 | (define vector-any? 179 | {(A --> boolean) --> (vector A) --> boolean} 180 | F V -> (vector-any'? F V (limit V))) 181 | 182 | (define vector-any'? 183 | {(A --> boolean) --> (vector A) --> number --> boolean} 184 | _ _ 0 -> false 185 | F V N -> true where (trap-error (F (<-vector V N)) (/. E false)) 186 | F V N -> (vector-any'? F V (- N 1))) 187 | 188 | (define vector-reverse 189 | {(vector A) --> (vector A)} 190 | V -> (let Limit (limit V) 191 | (vector-reverse' V (vector Limit) 1 Limit))) 192 | 193 | (define vector-reverse' 194 | {(vector A) --> (vector A) --> number --> number --> (vector A)} 195 | _ RV _ 0 -> RV 196 | V RV NV NVR -> (vector-reverse' V 197 | (trap-error (vector-> RV NVR (<-vector V NV)) (/. E RV)) 198 | (+ NV 1) 199 | (- NVR 1))) 200 | 201 | (define file->vectornum 202 | {string --> number --> (vector number)} 203 | File N -> (let Stream (open File in) 204 | (file->vectornum-help File Stream (read-byte Stream) (vector N) 1 N))) 205 | 206 | (define file->vectornum-help 207 | {string --> (stream in) --> number --> (vector number) --> number --> number --> (vector number)} 208 | File Stream -1 Vector Index N -> Vector 209 | File Stream Byte Vector Index N 210 | -> (file->vectornum-help 211 | File 212 | Stream 213 | (read-byte Stream) 214 | (trap-error (vector-> Vector Index Byte) 215 | (/. E (vector-> (vector-extend Vector N) Index Byte))) 216 | (+ Index 1) N)) 217 | 218 | (define file->vectorstring 219 | {string --> number --> (vector string)} 220 | File N -> (let Stream (open file File in) 221 | (file->vectorstring-help Stream (read-byte Stream) (vector N) 1 N))) 222 | 223 | (define file->vectorstring-help 224 | {(stream in) --> number --> (vector string) --> number --> number --> (vector string)} 225 | Stream -1 Vector Index N -> Vector 226 | Stream Byte Vector Index N 227 | -> (file->vectorstring-help 228 | Stream 229 | (read-byte Stream) 230 | (trap-error (vector-> Vector Index (n->string Byte)) 231 | (/. E (vector-> (vector-extend Vector N) 232 | Index 233 | (n->string Byte)))) 234 | (+ Index 1) N)) 235 | ) 236 | -------------------------------------------------------------------------------- /vectors/vectors.shen: -------------------------------------------------------------------------------- 1 | \* vectors.shen --- Vector utilities for shen 2 | 3 | Copyright (C) 2012, Dmitry Cherkassov 4 | 5 | *** License: 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions are 9 | met: 10 | 11 | - Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 14 | - Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | *** Commentary: 31 | 32 | This library implements a number of vector utilities 33 | 34 | *** Code: *\ 35 | 36 | (package vectors [vector-ref list->vector vector->list] 37 | 38 | \*---------------------------------------------------------------------------------*\ 39 | (define vector-ref 40 | \* returns n'th element of the vector and throws exception if (n > length) of list *\ 41 | {(vector A) --> number --> A} 42 | V N -> (<-vector V N) where (>= (limit V) N) 43 | _ _ -> (error "Out of bounds exception")) 44 | 45 | \*---------------------------------------------------------------------------------*\ 46 | (define list-vect-help 47 | {(list A) --> (vector A) --> number --> (vector A)} 48 | [] V _ -> V 49 | [A|B] V N -> (list-vect-help B (vector-> V N A) (+ N 1))) 50 | 51 | (define list->vector 52 | \* makes list->vector conversion *\ 53 | {(list A) --> (vector A)} 54 | L -> (list-vect-help L (vector (length L)) 1)) 55 | 56 | \*---------------------------------------------------------------------------------*\ 57 | (define vector->list-help 58 | {(vector A) --> number --> number --> (list A) --> (list A)} 59 | _ End End Acc -> (reverse Acc) 60 | V I End Acc -> (vector->list-help V (+ I 1) End [(<-vector V I) | Acc])) 61 | 62 | (define vector->list 63 | \* makes list->vector conversion *\ 64 | {(vector A) --> (list A)} 65 | V -> (vector->list-help V 1 (+ 1 (limit V)) [])) 66 | 67 | ) --------------------------------------------------------------------------------