├── .gitignore ├── doc ├── Using Match_files │ ├── 0.gif │ ├── 1.gif │ ├── ghostRightarrow.gif │ └── base.css └── Using Match.html ├── scripts └── run-tests.sh ├── lyonesse ├── strings.scm ├── aux-keyword.scm ├── munsch │ ├── random.cc │ ├── random.scm │ ├── ivector.scm │ ├── quaternions.scm │ ├── array.scm │ ├── slice.scm │ ├── geometry.scm │ ├── struct.scm │ ├── private.scm │ ├── nd-range.scm │ ├── array.old.scm │ ├── f32array.scm │ └── linear-algebra.scm ├── stack.scm ├── parsing │ ├── ast-builder │ │ ├── advanced.scm │ │ └── simple.scm │ ├── parser.scm │ ├── xml │ │ ├── clean.scm │ │ └── parser.scm │ └── xml.scm ├── oop.scm ├── foreign-data.scm ├── malloc.scm ├── ranges.scm ├── match │ └── compat.scm ├── contexts.scm ├── foreign-structs.scm ├── streams.scm ├── testing.scm ├── yasos.scm ├── record-with-context.scm ├── munsch.scm ├── streams │ ├── primitive.scm │ └── derived.scm ├── cut.scm └── functional.scm ├── .editorconfig ├── test ├── test-record-with-context.scm ├── test-xml.scm ├── test-parser.scm ├── test-yasos.scm ├── test-stack.scm ├── test-sexpr-builder.scm └── test-functional.scm ├── README.md ├── gtk-tutorial └── window.scm └── LICENSE-2.0.txt /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.swp 3 | *.swo 4 | 5 | *.so 6 | 7 | -------------------------------------------------------------------------------- /doc/Using Match_files/0.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jhidding/lyonesse/HEAD/doc/Using Match_files/0.gif -------------------------------------------------------------------------------- /doc/Using Match_files/1.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jhidding/lyonesse/HEAD/doc/Using Match_files/1.gif -------------------------------------------------------------------------------- /doc/Using Match_files/ghostRightarrow.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jhidding/lyonesse/HEAD/doc/Using Match_files/ghostRightarrow.gif -------------------------------------------------------------------------------- /scripts/run-tests.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | test_files=$(find test -name 'test*.scm') 4 | 5 | for f in ${test_files} 6 | do 7 | echo "#| ${f} |#" 8 | scheme-script ${f} 9 | done 10 | 11 | -------------------------------------------------------------------------------- /lyonesse/strings.scm: -------------------------------------------------------------------------------- 1 | #| SRFI-1 contains many functions that are also in RnRS. We need a 2 | | port with only the useful extras. 3 | |# 4 | (library (lyonesse strings) 5 | (export string-join) 6 | (import (rnrs base (6)) 7 | (rnrs lists (6)) 8 | (lyonesse functional)) 9 | 10 | (define (string-join sep lst) 11 | (if (null? lst) 12 | "" 13 | (fold-left ($ string-append <> sep <>) (car lst) (cdr lst)))) 14 | ) 15 | -------------------------------------------------------------------------------- /lyonesse/aux-keyword.scm: -------------------------------------------------------------------------------- 1 | #| Code snippet from Andy Keep |# 2 | (library (lyonesse aux-keyword) 3 | (export define-auxiliary-keyword 4 | define-auxiliary-keywords) 5 | 6 | (import (rnrs (6))) 7 | 8 | (define-syntax define-auxiliary-keyword 9 | (syntax-rules () 10 | [(_ name) 11 | (define-syntax name 12 | (lambda (x) 13 | (syntax-violation #f "misplaced use of auxiliary keyword" x)))])) 14 | 15 | (define-syntax define-auxiliary-keywords 16 | (syntax-rules () 17 | [(_ name* ...) 18 | (begin (define-auxiliary-keyword name*) ...)])) 19 | ) 20 | -------------------------------------------------------------------------------- /lyonesse/munsch/random.cc: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | std::mt19937 random_engine; 6 | 7 | extern "C" void random_seed(uint64_t seed) 8 | { 9 | random_engine.seed(seed); 10 | } 11 | 12 | extern "C" void randomize_timer() 13 | { 14 | uint64_t n = std::chrono::system_clock::now() 15 | .time_since_epoch().count(); 16 | random_seed(n); 17 | } 18 | 19 | extern "C" int random_integer(int a, int b) 20 | { 21 | return std::uniform_int_distribution(a, b)(random_engine); 22 | } 23 | 24 | extern "C" double random_uniform_real(double a, double b) 25 | { 26 | return std::uniform_real_distribution(a, b)(random_engine); 27 | } 28 | 29 | -------------------------------------------------------------------------------- /lyonesse/munsch/random.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse munsch random) 2 | (export random-seed randomize-timer random-integer random-uniform-real) 3 | (import (rnrs base (6)) 4 | (only (chezscheme) load-shared-object foreign-procedure)) 5 | 6 | (define librandom (load-shared-object "random.so")) 7 | 8 | (define random-seed 9 | (foreign-procedure "random_seed" (unsigned-64) void)) 10 | 11 | (define randomize-timer 12 | (foreign-procedure "randomize_timer" () void)) 13 | 14 | (define random-integer 15 | (foreign-procedure "random_integer" (int int) int)) 16 | 17 | (define random-uniform-real 18 | (foreign-procedure "random_uniform_real" (double double) double)) 19 | ) 20 | -------------------------------------------------------------------------------- /doc/Using Match_files/base.css: -------------------------------------------------------------------------------- 1 | BODY {background-color: #FFFFFF} 2 | A:link {color:blue; text-decoration:none} 3 | A:active {color:blue; text-decoration:none} 4 | A:visited {color:maroon; text-decoration:none} 5 | A:hover {color:white; text-decoration:none; background:blue} 6 | A.ref:link {color:blue; text-decoration:underline} 7 | A.ref:active {color:blue; text-decoration:underline} 8 | A.ref:visited {color:blue; text-decoration:underline} 9 | A.ref:hover {color:white; text-decoration:underline; background:blue} 10 | A.plainlink:link {color:blue; text-decoration:none} 11 | A.plainlink:active {color:blue; text-decoration:none} 12 | A.plainlink:visited {color:blue; text-decoration:none} 13 | A.plainlink:hover {color:white; text-decoration:none; background:blue} 14 | 15 | table.indent {margin-left: 20px} 16 | -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | # EditorConfig is awesome: http://EditorConfig.org 2 | 3 | # top-most EditorConfig file 4 | root = true 5 | 6 | # Unix-style newlines with a newline ending every file 7 | [*] 8 | end_of_line = lf 9 | insert_final_newline = true 10 | trim_trailing_whitespace = true 11 | charset = utf-8 12 | 13 | # Matches multiple files with brace expansion notation 14 | # Set default charset 15 | [*.{js,py,java,r,R}] 16 | indent_style = space 17 | 18 | # 4 space indentation 19 | [*.py] 20 | indent_size = 4 21 | 22 | # Tab indentation (no size specified) 23 | [*.js] 24 | indent_size = 2 25 | 26 | # Matches the exact files either package.json or .travis.yml 27 | [*.{json,yml}] 28 | indent_size = 2 29 | 30 | [*.{md,Rmd}] 31 | trim_trailing_whitespace = false 32 | 33 | [*.{cpp,hpp,cc,hh,c,h,cuh,cu}] 34 | indent_size = 4 35 | indent_style = space 36 | 37 | [*.{sls,scm,ss}] 38 | indent_size = 2 39 | indent_style = space 40 | 41 | -------------------------------------------------------------------------------- /lyonesse/stack.scm: -------------------------------------------------------------------------------- 1 | #| Copyright 2016 Johan Hidding 2 | | 3 | | Licensed under the Apache License, Version 2.0 (the "License"); 4 | | you may not use this file except in compliance with the License. 5 | | You may obtain a copy of the License at 6 | | 7 | | http://www.apache.org/licenses/LICENSE-2.0 8 | | 9 | | Unless required by applicable law or agreed to in writing, software 10 | | distributed under the License is distributed on an "AS IS" BASIS, 11 | | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | | See the License for the specific language governing permissions and 13 | | limitations under the License. 14 | |# 15 | 16 | (library (lyonesse stack) 17 | (export make-stack) 18 | 19 | (import (rnrs (6)) 20 | (lyonesse oop)) 21 | 22 | (define-object (make-stack) 23 | ([lst '()]) 24 | ([empty? (lambda () (null? lst))] 25 | [push! (lambda (value) (set! lst (cons value lst)))] 26 | [top (lambda () (car lst))] 27 | [pop! (lambda () (set! lst (cdr lst)))])) 28 | ) 29 | 30 | -------------------------------------------------------------------------------- /test/test-record-with-context.scm: -------------------------------------------------------------------------------- 1 | (import (rnrs (6)) 2 | (prefix (lyonesse testing) test:) 3 | (lyonesse functional) 4 | (lyonesse record-with-context)) 5 | 6 | (define-record-with-context my-vector 7 | (fields x y)) 8 | 9 | (define-record-with-context A 10 | (fields p q)) 11 | 12 | (define-record-with-context p 13 | (fields k l m)) 14 | 15 | (define (my-vector-length v) 16 | (with-my-vector v (sqrt (+ (* x x) (* y y))))) 17 | 18 | (test:unit "record type with context manager" 19 | ([v (make-my-vector 3 4)]) 20 | 21 | (test:that "syntax works" 22 | (= 5 (my-vector-length v))) 23 | 24 | (test:that "names don't collide" 25 | (let ([a (make-A (make-p 1 2 3) 4)]) 26 | (= 1 (with-A a (with-p p k))) 27 | (= 3 (with-A a (with-p p m))) 28 | (= 4 (with-A a q)))) 29 | 30 | (test:that "updating works" 31 | (let* ([a (make-A (make-p 1 2 3) 4)] 32 | [b (update-A a (q 8) (p (update-p p (l 42))))]) 33 | (= 8 (with-A a q)) 34 | (= 42 (with-A a (with-p p l))) 35 | (= 3 (with-A a (with-p p m))))) 36 | ) 37 | -------------------------------------------------------------------------------- /test/test-xml.scm: -------------------------------------------------------------------------------- 1 | (import (rnrs (6)) 2 | (prefix (lyonesse testing) test:) 3 | (lyonesse functional) 4 | (lyonesse parsing xml)) 5 | 6 | (test:unit "some basic XML" 7 | ([parse xml:from-string]) 8 | 9 | (test:that "header is read" 10 | (equal? (parse "\ 11 | Hello World!") 12 | '((? xml ((version . "1.0") (encoding . "UTF-8"))) 13 | (body () "Hello World!")))) 14 | 15 | (test:that "attributes parse" 16 | (equal? (parse "") 17 | '((a ((x . "1") (y . "2")))))) 18 | 19 | (test:that "hierarchy is preserved" 20 | (equal? (parse "hello") 21 | '((a ((x . "goodbye")) (b ()) "hello" (c ()))))) 22 | 23 | (test:that "special characters are parsed" 24 | (equal? (parse "The magic five: &'"<>.") 25 | '((a () "The magic five: &'\"<>.")))) 26 | 27 | (test:that "comments are ignored" 28 | (equal? (parse "") 29 | '((a ())))) 30 | ) 31 | 32 | -------------------------------------------------------------------------------- /lyonesse/parsing/ast-builder/advanced.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse sexpr-builder) 2 | (export sb:start sb:new sb:add sb:close) 3 | (import (rnrs base (6)) 4 | (rnrs records syntactic (6)) 5 | (lyonesse functional)) 6 | 7 | (define-record-type sb:state 8 | (fields parent data check transfer)) 9 | 10 | (define (sb:state-values state) 11 | (values (sb:state-parent state) (sb:state-data state) 12 | (sb:state-check state) (sb:state-transfer state))) 13 | 14 | (define (sb:pop state) 15 | (let*-values ([(p d c t) (sb:state-values state)] 16 | [r (t (reverse d))]) 17 | (if (c and (c r)) 18 | (p r) 19 | (error sb:pop "Check failed." c r)))) 20 | 21 | (define (sb:new state check transfer) 22 | (make-sb:state 23 | (lambda (x) 24 | (sb:add state x)) 25 | '() 26 | check 27 | transfer)) 28 | 29 | (define (sb::add state item) 30 | (let-values ([(p d c t) (sb:state-values state)]) 31 | (make-sb:state p (cons item d) c t))) 32 | 33 | (define (sb::set-check state check) 34 | (let-values ([(p d c t) (sb:state-values state)]) 35 | (make-sb:state p d check t))) 36 | ) 37 | -------------------------------------------------------------------------------- /lyonesse/oop.scm: -------------------------------------------------------------------------------- 1 | #| This code is from R. Kent Dybvig's book 'The Scheme Programming Language', 2 | | 4th edition, section 12.8. 3 | |# 4 | 5 | (library (lyonesse oop) 6 | (export define-object send) 7 | 8 | (import (rnrs (6))) 9 | 10 | (define-syntax define-object 11 | (syntax-rules () 12 | [(_ ( . ) 13 | (( ) ...) 14 | (( ) ...)) 15 | (define 16 | (lambda 17 | (let* ([ ] ...) 18 | (letrec ([ ] ...) 19 | (lambda (msg . args) 20 | (case msg 21 | [() (apply args)] 22 | ... 23 | [else (assertion-violation 24 | ' "invalid message" 25 | (cons msg args))]))))))] 26 | 27 | [(_ ( . ) 28 | (( )...)) 29 | (define-object ( . ) 30 | () 31 | (( ) ...))])) 32 | 33 | (define-syntax send 34 | (syntax-rules () 35 | [(_ ...) 36 | ( ' ...)])) 37 | ) 38 | 39 | -------------------------------------------------------------------------------- /lyonesse/parsing/parser.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse parsing parser) 2 | (export define-parser) 3 | (import (rnrs base (6)) 4 | (rnrs syntax-case (6)) 5 | (only (rnrs io ports (6)) get-char) 6 | (only (lyonesse functional) pipe)) 7 | 8 | (define-syntax define-parser 9 | (lambda (x) 10 | (syntax-case x (else) 11 | [(_ ( ) 12 | [ ( ...)] ... 13 | [else ( ...)]) 14 | (syntax 15 | (define ( state input) 16 | (let ([ (get-char input)]) 17 | (cond 18 | [( ) 19 | ( (pipe state ...) input)] 20 | ... 21 | [else 22 | ( (pipe state ...) input)]))))] 23 | 24 | [(_ ( ) 25 | [ ( ...)] ...) 26 | (syntax 27 | (define ( state input) 28 | (let ([ (get-char input)]) 29 | (cond 30 | [( ) 31 | ( (pipe state ...) input)] 32 | ...))))]))) 33 | ) 34 | -------------------------------------------------------------------------------- /lyonesse/foreign-data.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse foreign-data) 2 | 3 | (export deref string->char* get-value-by-ref) 4 | 5 | (import (rnrs base (6)) 6 | (rnrs bytevectors (6)) 7 | 8 | (lyonesse malloc) 9 | (lyonesse functional) 10 | 11 | (only (chezscheme) foreign-ref foreign-set! foreign-sizeof unbox 12 | foreign-free foreign-alloc)) 13 | 14 | (define (new type) 15 | (malloc (foreign-sizeof type))) 16 | 17 | (define (deref type obj) 18 | (let ([data (new type)]) 19 | (foreign-set! type (unbox data) 0 (unbox obj)) 20 | data)) 21 | 22 | (define (string->char* s) 23 | (let* ([bv (string->utf8 s)] 24 | [n (bytevector-length bv)] 25 | [fm (malloc (+ n 1))]) 26 | (for-each (lambda (i) 27 | (foreign-set! 'unsigned-8 (unbox fm) i 28 | (bytevector-u8-ref bv i))) 29 | (iota (bytevector-length bv))) 30 | (foreign-set! 'unsigned-8 (unbox fm) n 0) 31 | fm)) 32 | 33 | (define (get-value-by-ref type proc) 34 | (let ([x (foreign-alloc (foreign-sizeof type))]) 35 | (proc x) 36 | (let ([value (foreign-ref type x 0)]) 37 | (foreign-free x) 38 | value))) 39 | ) 40 | -------------------------------------------------------------------------------- /test/test-parser.scm: -------------------------------------------------------------------------------- 1 | (import (rnrs (6)) 2 | (prefix (lyonesse testing) test:) 3 | (lyonesse aux-keyword) 4 | (lyonesse functional) 5 | (lyonesse parser) 6 | (lyonesse sexpr-builder simple)) 7 | 8 | 9 | (define (parse:error state input) 10 | (error parse:error "Error parsing." state input)) 11 | 12 | (define (parse:exit state input) 13 | state) 14 | 15 | (define-parser (parse:expr ch) 16 | [eof-object? parse:exit (sb:close-all)] 17 | [char-whitespace? parse:expr ()] 18 | [char-numeric? parse:number (sb:new-string 19 | (sb:add ch))] 20 | [($ memq <> '(#\- #\+ #\* #\/)) 21 | parse:expr (sb:new-symbol 22 | (sb:add ch) 23 | sb:close)] 24 | [else parse:error (sb:close-all)]) 25 | 26 | (define-parser (parse:number ch) 27 | [eof-object? parse:exit (sb:close-all)] 28 | [char-numeric? parse:number ((sb:add ch))] 29 | [char-whitespace? parse:expr (sb:close)] 30 | [else parse:error (sb:close-all)]) 31 | 32 | 33 | (test:unit "small parser" 34 | ([input (open-string-input-port "6 * 7")]) 35 | 36 | (test:that "we can read expression" 37 | (equal? '("6" * "7") (parse:expr (sb:start) input)))) 38 | 39 | -------------------------------------------------------------------------------- /lyonesse/munsch/ivector.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse munsch ivector) 2 | (export make-ivector ivector? ivector-set! ivector-ref m:iv) 3 | (import (rnrs base (6)) 4 | (rnrs bytevectors (6))) 5 | 6 | (define bv-i32-ref bytevector-i32-native-ref) 7 | (define bv-i32-set! bytevector-i32-native-set!) 8 | 9 | #| Vector essentials ===================================================== |# 10 | (define-record-type ivector 11 | (fields length data) 12 | (protocol 13 | (lambda (new) 14 | (case-lambda 15 | [(l) (new l (make-bytevector (* l 4)))] 16 | [(l data) (new l data)])))) 17 | 18 | (define (ivector-ref v n) 19 | (bv-i32-ref (ivector-data v) (* n 4))) 20 | 21 | (define (ivector-set! v n x) 22 | (bv-i32-set! (ivector-data v) (* n 4) x)) 23 | 24 | #| Vector construction =================================================== |# 25 | (define-syntax m:iv 26 | (lambda (x) 27 | (syntax-case x () 28 | [(_ ...) 29 | #`(let* ([v (make-ivector #,(length #'( ...)))] 30 | [d (ivector-data v)]) 31 | #,@(map (lambda (x n) 32 | #`(bv-i32-set! d #,(* 4 n) #,x)) 33 | #'( ...) 34 | (iota (length #'( ...)))) 35 | v)]))) 36 | ) 37 | -------------------------------------------------------------------------------- /lyonesse/parsing/xml/clean.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse parsing xml clean) 2 | (export xml:clean) 3 | (import (rnrs base (6)) 4 | (only (srfi :13) string-trim-both) 5 | (lyonesse match) 6 | (lyonesse functional)) 7 | 8 | (define (xml:tags-match? a b) 9 | (let* ([a0 (symbol->string a)] 10 | [b0 (symbol->string b)] 11 | [b1 (substring b0 1 (string-length b0))]) 12 | (and (char=? (string-ref b0 0) #\/) 13 | (equal? a0 b1)))) 14 | 15 | (define (xml:clean ast) 16 | (match ast 17 | [() '()] 18 | [(,a ,[content] ... ,b) (guard (symbol? a) (symbol? b) 19 | (xml:tags-match? a b)) 20 | (cons a content)] 21 | [(? ,a ,[content] ?) (guard (symbol? a)) 22 | (list '? a content)] 23 | [(~ (,attrs ,valus) ...) (guard (and (all? symbol? attrs) 24 | (all? string? valus))) 25 | (map cons attrs valus)] 26 | [(,a ,[content] ...) (guard (symbol? a)) 27 | (cons a content)] 28 | [,a (guard (string? a)) (string-trim-both a)] 29 | [,a (error 'xml:clean "XML AST is unclean." a)])) 30 | ) 31 | -------------------------------------------------------------------------------- /lyonesse/malloc.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse malloc) 2 | (export malloc) 3 | 4 | (import (rnrs base (6)) 5 | (rnrs control (6)) 6 | (only (chezscheme) foreign-alloc foreign-free 7 | box unbox 8 | make-guardian 9 | collect-request-handler collect)) 10 | 11 | ;(define-record-type (box box box?) 12 | ; (fields (mutable element unbox set-box!))) 13 | 14 | (define (do-malloc size) 15 | (box (foreign-alloc size))) 16 | 17 | (define (do-free x) 18 | (foreign-free (unbox x))) 19 | 20 | #| Malloc allocates memory, returning a pointer in boxed form. This box is 21 | | guarded so that the memory is automatically freed when there are no 22 | | references to the pointer left. 23 | | 24 | | Code from Chez Scheme User Guide (9.4) 25 | |# 26 | 27 | (define malloc-guardian (make-guardian)) 28 | 29 | (define (malloc size) 30 | (let ([x (do-malloc size)]) 31 | (malloc-guardian x) 32 | x)) 33 | 34 | (collect-request-handler 35 | (lambda () 36 | ; first, invoke the collector 37 | (collect) 38 | ; then free any storage that has been dropped 39 | (let f () 40 | (let ([x (malloc-guardian)]) 41 | (when x 42 | (do-free x) 43 | (f)))))) 44 | ) 45 | -------------------------------------------------------------------------------- /test/test-yasos.scm: -------------------------------------------------------------------------------- 1 | #| Copyright 2016 Johan Hidding 2 | | 3 | | Licensed under the Apache License, Version 2.0 (the "License"); 4 | | you may not use this file except in compliance with the License. 5 | | You may obtain a copy of the License at 6 | | 7 | | http://www.apache.org/licenses/LICENSE-2.0 8 | | 9 | | Unless required by applicable law or agreed to in writing, software 10 | | distributed under the License is distributed on an "AS IS" BASIS, 11 | | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | | See the License for the specific language governing permissions and 13 | | limitations under the License. 14 | |# 15 | 16 | (import (rnrs (6)) 17 | (lyonesse yasos) 18 | (prefix (lyonesse testing) test:) 19 | (srfi :48)) 20 | 21 | (define-predicate lvector?) 22 | (define-operation (get-x obj)) 23 | (define-operation (get-y obj)) 24 | (define-operation (print obj port)) 25 | (define-operation (blah obj)) 26 | 27 | (define (make-lvector x y) 28 | (object 29 | ((lvector? self) #t) 30 | ((get-x self) x) 31 | ((get-y self) y) 32 | ((print self port) 33 | (format port "#(~a ~a)" x y)))) 34 | 35 | (test:unit "lvector object" 36 | [(a (make-lvector 3 4))] 37 | (test:that "lvector type is working" 38 | (= 3 (get-x a)) 39 | (= 4 (get-y a)))) 40 | 41 | -------------------------------------------------------------------------------- /test/test-stack.scm: -------------------------------------------------------------------------------- 1 | #| Copyright 2016 Johan Hidding 2 | | 3 | | Licensed under the Apache License, Version 2.0 (the "License"); 4 | | you may not use this file except in compliance with the License. 5 | | You may obtain a copy of the License at 6 | | 7 | | http://www.apache.org/licenses/LICENSE-2.0 8 | | 9 | | Unless required by applicable law or agreed to in writing, software 10 | | distributed under the License is distributed on an "AS IS" BASIS, 11 | | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | | See the License for the specific language governing permissions and 13 | | limitations under the License. 14 | |# 15 | 16 | (import (rnrs (6)) 17 | (lyonesse oop) 18 | (prefix (lyonesse testing) test:) 19 | (lyonesse stack)) 20 | 21 | (test:unit "stack" 22 | ((S (make-stack))) 23 | 24 | (test:that "stack is empty" 25 | (send S empty?)) 26 | 27 | (test:that "we can push" 28 | (begin (send S push! 3) (send S push! 4) (send S push! 5) #t)) 29 | 30 | (test:that "stack is non-empty" 31 | (not (send S empty?))) 32 | 33 | (test:that "we can see the top" 34 | (= (send S top) 5)) 35 | 36 | (test:that "we can pop" 37 | (begin (send S pop!) (= (send S top) 4)) 38 | (begin (send S pop!) (= (send S top) 3)) 39 | (begin (send S pop!) #t)) 40 | 41 | (test:that "stack is empty" 42 | (send S empty?))) 43 | 44 | -------------------------------------------------------------------------------- /lyonesse/ranges.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse ranges) 2 | (export range for-range map-range reduce-range) 3 | (import (rnrs base (6)) 4 | (rnrs control (6))) 5 | 6 | (define range 7 | (case-lambda 8 | [(b) (range 0 b 1)] 9 | [(a b) (range a b 1)] 10 | [(a b dx) (let loop ([lst '()] 11 | [x a]) 12 | (if (>= x b) 13 | (reverse lst) 14 | (loop (cons x lst) (+ x dx))))])) 15 | 16 | (define for-range 17 | (case-lambda 18 | [(f b) (for-range f 0 b 1)] 19 | [(f a b) (for-range f a b 1)] 20 | [(f a b dx) (unless (>= a b) 21 | (f a) 22 | (for-range f (+ a dx) b dx))])) 23 | 24 | (define map-range 25 | (case-lambda 26 | [(f b) (map-range f 0 b 1)] 27 | [(f a b) (map-range f a b 1)] 28 | [(f a b dx) (let loop ([x a] 29 | [result '()]) 30 | (if (>= x b) 31 | (reverse result) 32 | (loop (+ x dx) (cons (f x) result))))])) 33 | 34 | (define reduce-range 35 | (case-lambda 36 | [(f start b) (reduce-range f start 0 b 1)] 37 | [(f start a b) (reduce-range f start a b 1)] 38 | [(f start a b dx) (if (>= a b) 39 | start 40 | (reduce-range f (f start a) (+ a dx) b dx))])) 41 | ) 42 | -------------------------------------------------------------------------------- /lyonesse/match/compat.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse match compat) 2 | 3 | (export add1 sub1 syntax-error andmap with-implicit make-list 4 | rec last-pair make-parameter) 5 | 6 | (import (rnrs (6))) 7 | 8 | (define (add1 x) (+ 1 x)) 9 | (define (sub1 x) (- x 1)) 10 | 11 | (define (syntax-error obj . msgs) 12 | (let ((msg (if (null? msgs) 13 | "invalid syntax." 14 | (string-append msgs)))) 15 | (error 'syntax-error msg))) 16 | 17 | (define andmap for-all) 18 | 19 | (define-syntax with-implicit 20 | (syntax-rules () 21 | [(_ (tid id ...) b1 b2 ...) 22 | (with-syntax ([id (datum->syntax #'tid 'id)] ...) 23 | b1 b2 ...)])) 24 | 25 | (define make-list 26 | (case-lambda 27 | ((n) (make-list n #f)) 28 | ((n obj) (let loop ([n n] [result '()]) 29 | (if (= n n) result (loop (add1 n) (cons obj result))))))) 30 | 31 | (define-syntax rec 32 | (syntax-rules () 33 | [(_ x e) (letrec ((x e)) x)])) 34 | 35 | (define (last-pair l) 36 | (cond 37 | ((null? l) (error 'last-pair "list must not be empty." l)) 38 | ((null? (cdr l)) l) 39 | (else (last-pair (cdr l))))) 40 | 41 | (define make-parameter 42 | (case-lambda 43 | [(init guard) 44 | (let ([v (guard init)]) 45 | (case-lambda 46 | [() v] 47 | [(u) (set! v (guard u))]))] 48 | [(init) 49 | (make-parameter init (lambda (x) x))])) 50 | ) 51 | -------------------------------------------------------------------------------- /lyonesse/contexts.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse contexts) 2 | (export define-context) 3 | (import (rnrs base (6)) 4 | (rnrs syntax-case (6)) 5 | (only (chezscheme) trace-define-syntax)) 6 | 7 | (trace-define-syntax define-context 8 | (lambda (x) 9 | ; Define a new symbol, code from TSPL Chapter 8. 10 | (define gen-id 11 | (lambda (template-id . args) 12 | (datum->syntax template-id 13 | (string->symbol 14 | (apply string-append 15 | (map (lambda (x) 16 | (if (string? x) 17 | x 18 | (symbol->string (syntax->datum x)))) 19 | args)))))) 20 | 21 | (syntax-case x (fields) 22 | [(define-context (fields ...)) 23 | (with-syntax ([ (gen-id #' "with-" #')] 24 | ; Define the names of member access functions. 25 | [( ...) (map (lambda (x) 26 | (gen-id x #' "-" x)) 27 | #'( ...))]) 28 | #'(define-syntax 29 | (lambda (x) 30 | (syntax-case x () 31 | [( (... ...)) 32 | (with-syntax ([ (datum->syntax #' ')] 33 | ...) 34 | #'(let ([ ( )] ...) 35 | (... ...)))]))))]))) 36 | ) 37 | 38 | -------------------------------------------------------------------------------- /test/test-sexpr-builder.scm: -------------------------------------------------------------------------------- 1 | (import (rnrs (6)) 2 | (prefix (lyonesse testing) test:) 3 | (lyonesse functional) 4 | (lyonesse parsing ast-builder simple)) 5 | 6 | (test:unit "simple sexpr builder" 7 | () 8 | 9 | (test:that "correct values are returned" 10 | (equal? (pipe (sb:start) sb:close) '()) 11 | (equal? (sb:close ((sb:add 4) ((sb:add 5) (sb:start)))) 12 | '(5 4)) 13 | (equal? (pipe (sb:start) 14 | (sb:add 1) 15 | sb:new-list 16 | (sb:add 2) 17 | (sb:add 3) 18 | sb:close 19 | (sb:add 4) 20 | sb:close) 21 | '(1 (2 3) 4)) 22 | (equal? (pipe (sb:start) 23 | sb:new-string 24 | (sb:add #\h) 25 | (sb:add #\e) 26 | (sb:add #\l) 27 | (sb:add #\l) 28 | (sb:add #\o) 29 | sb:close sb:close) 30 | '("hello")) 31 | (equal? (pipe (sb:start) 32 | sb:new-symbol 33 | (sb:add #\l) 34 | (sb:add #\a) 35 | (sb:add #\m) 36 | (sb:add #\b) 37 | (sb:add #\d) 38 | (sb:add #\a) 39 | sb:close sb:close) 40 | '(lambda)) 41 | (= 7.89 (car (pipe (sb:start) 42 | sb:new-datum 43 | (sb:add #\7) 44 | (sb:add #\.) 45 | (sb:add #\8) 46 | (sb:add #\9) 47 | sb:close sb:close))) 48 | )) 49 | -------------------------------------------------------------------------------- /lyonesse/foreign-structs.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse foreign-structs) 2 | (export define-foreign-struct) 3 | (import (rnrs base (6)) 4 | (rnrs syntax-case (6)) 5 | (only (chezscheme) define-ftype ftype-ref trace-define-syntax)) 6 | 7 | (define-syntax define-foreign-struct 8 | (lambda (x) 9 | ; Define a new symbol, code from TSPL Chapter 8. 10 | (define gen-id 11 | (lambda (template-id . args) 12 | (datum->syntax template-id 13 | (string->symbol 14 | (apply string-append 15 | (map (lambda (x) 16 | (if (string? x) 17 | x 18 | (symbol->string (syntax->datum x)))) 19 | args)))))) 20 | 21 | (syntax-case x () 22 | [(define-foreign-struct ( ) ...) 23 | (with-syntax ([ (gen-id #' "with-" #')] 24 | ; Define the names of member access functions. 25 | [( ...) (map (lambda (x) 26 | (gen-id x #' "-" x)) 27 | #'( ...))]) 28 | #'(begin 29 | (define-ftype 30 | (struct ( ) ...)) 31 | 32 | (define-syntax 33 | (lambda (x) 34 | (syntax-case x () 35 | [( (... ...)) 36 | (with-syntax ([ (datum->syntax #' ')] 37 | ...) 38 | #'(let ([ (ftype-ref () )] ...) 39 | (... ...)))])))))]))) 40 | ) 41 | 42 | -------------------------------------------------------------------------------- /lyonesse/streams.scm: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) Philip L. Bewig (2007). All Rights Reserved. 2 | ;;; Permission is hereby granted, free of charge, to any person 3 | ;;; obtaining a copy of this software and associated documentation files 4 | ;;; (the "Software"), to deal in the Software without restriction, 5 | ;;; including without limitation the rights to use, copy, modify, merge, 6 | ;;; publish, distribute, sublicense, and/or sell copies of the Software, 7 | ;;; and to permit persons to whom the Software is furnished to do so, 8 | ;;; subject to the following conditions: 9 | ;;; 10 | ;;; The above copyright notice and this permission notice shall be 11 | ;;; included in all copies or substantial portions of the Software. 12 | ;;; 13 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 14 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 15 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 16 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 17 | ;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 18 | ;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 19 | ;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 20 | ;;; SOFTWARE. 21 | 22 | (library (lyonesse streams) 23 | (export stream-null stream-cons stream? stream-null? stream-pair? stream-car 24 | stream-cdr stream-lambda define-stream list->stream port->stream 25 | stream stream->list stream-append stream-concat stream-constant 26 | stream-drop stream-drop-while stream-filter stream-fold 27 | stream-for-each stream-from stream-iterate stream-length stream-let 28 | stream-map stream-match stream-of stream-range stream-ref 29 | stream-reverse stream-scan stream-take stream-take-while 30 | stream-unfold stream-unfolds stream-zip) 31 | 32 | (import (lyonesse streams primitive) 33 | (lyonesse streams derived))) 34 | -------------------------------------------------------------------------------- /lyonesse/testing.scm: -------------------------------------------------------------------------------- 1 | #| Copyright 2016 Johan Hidding 2 | | 3 | | Licensed under the Apache License, Version 2.0 (the "License"); 4 | | you may not use this file except in compliance with the License. 5 | | You may obtain a copy of the License at 6 | | 7 | | http://www.apache.org/licenses/LICENSE-2.0 8 | | 9 | | Unless required by applicable law or agreed to in writing, software 10 | | distributed under the License is distributed on an "AS IS" BASIS, 11 | | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | | See the License for the specific language governing permissions and 13 | | limitations under the License. 14 | |# 15 | 16 | (library (lyonesse testing) 17 | (export run-test that unit) 18 | 19 | (import (rnrs (6)) 20 | (rnrs records syntactic (6)) 21 | (only (chezscheme) pretty-print pretty-initial-indent) 22 | (srfi :48)) 23 | 24 | (define-record-type test 25 | (fields description assertions)) 26 | 27 | (define-syntax that 28 | (syntax-rules () 29 | [(_ ...) 30 | (make-test 31 | (list (lambda () 32 | (format #t " \x1b;[30;1m•\x1b;[m ") 33 | (pretty-initial-indent 6) 34 | (pretty-print ') 35 | ) ...))])) 36 | 37 | (define (run-test test) 38 | (format #t "\x1b;[30;1m◇\x1b;[m ~a~%" (test-description test)) 39 | (for-each (lambda (t) (if (t) (format #t " \x1b;[32m✔\x1b;[m~%") 40 | (format #t " \x1b;[31m✘\x1b;[m~%"))) 41 | (test-assertions test))) 42 | 43 | (define-syntax unit 44 | (syntax-rules () 45 | [(_ ([ ] ...) 46 | ...) 47 | (letrec* [( ) ...] 48 | (let ([tests (list ...)]) 49 | (format #t " - \x1b;[34;1m~a\x1b;[m - ~%" ) 50 | (for-each (lambda (f) (run-test f)) tests)))])) 51 | ) 52 | -------------------------------------------------------------------------------- /lyonesse/munsch/quaternions.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse munsch quaternions) 2 | 3 | (export g:make-quat g:quat? g:quat-vector g:quat-scalar 4 | rotation-quat scalar-quat quat-mul 5 | quat-conj quat-sqr quat-scale quat-inv 6 | quat-conjugation) 7 | 8 | (import (rnrs (6)) 9 | (lyonesse functional) 10 | (lyonesse munsch geometry)) 11 | 12 | ;;;====================================================== 13 | ;;; quaternion 14 | ;;;------------------------------------------------------ 15 | (define-record-type (g:quat g:make-quat g:quat?) 16 | (fields scalar vector)) 17 | 18 | (define (g:rotation-quat u theta) 19 | (g:make-quat (cos (/ theta 2)) 20 | (g:* (sin (/ theta 2)) u))) 21 | 22 | (define (g:scalar-quat s) 23 | (g:make-quat s (g:> 0 0 0))) 24 | 25 | ;;;====================================================== 26 | ;;; multiplication 27 | ;;;------------------------------------------------------ 28 | (define (g:quat-mul2 q2 q1) 29 | (g:make-quat 30 | (- (* (g:quat-scalar q1) (g:quat-scalar q2)) 31 | (g:dot (g:quat-vector q1) (g:quat-vector q2))) 32 | 33 | (g:+ (g:* (g:quat-scalar q1) (g:quat-vector q2)) 34 | (g:* (g:quat-scalar q2) (g:quat-vector q1)) 35 | (g:cross (g:quat-vector q1) (g:quat-vector q2))))) 36 | 37 | (define (g:quat:* q . qs) 38 | (fold-right quat-mul2 q qs)) 39 | 40 | ;;;====================================================== 41 | ;;; other operations 42 | ;;;------------------------------------------------------ 43 | (define (g:quat:conj q) 44 | (g:make-quat (g:quat-scalar q) (g:- (g:quat-vector q)))) 45 | 46 | (define (g:quat:sqr q) 47 | (+ (* (g:quat-scalar q) (g:quat-scalar q)) 48 | (g:dot (g:quat-vector q) (g:quat-vector q)))) 49 | 50 | (define (g:quat:scale s q) 51 | (g:make-quat (* s (g:quat-scalar q)) 52 | (g:* s (s:quat-vector q)))) 53 | 54 | (define (g:quat:inv q) 55 | (g:quat:scale (/ 1 (g:quat:sqr q)) 56 | (g:quat:conj q))) 57 | 58 | ;;;====================================================== 59 | ;;; vector conjugation 60 | ;;;------------------------------------------------------ 61 | (define (g:quat:vector-conjugate q v) 62 | (g:quat-vector 63 | (g:quat:* q (g:make-quat 0.0 v) (g:quat:conj q)))) 64 | ) 65 | 66 | -------------------------------------------------------------------------------- /test/test-functional.scm: -------------------------------------------------------------------------------- 1 | #| Copyright 2016 Johan Hidding 2 | | 3 | | Licensed under the Apache License, Version 2.0 (the "License"); 4 | | you may not use this file except in compliance with the License. 5 | | You may obtain a copy of the License at 6 | | 7 | | http://www.apache.org/licenses/LICENSE-2.0 8 | | 9 | | Unless required by applicable law or agreed to in writing, software 10 | | distributed under the License is distributed on an "AS IS" BASIS, 11 | | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | | See the License for the specific language governing permissions and 13 | | limitations under the License. 14 | |# 15 | 16 | (import (rnrs (6)) 17 | (only (srfi :1) unfold) 18 | (prefix (lyonesse testing) test:) 19 | (lyonesse aux-keyword) 20 | (lyonesse functional)) 21 | 22 | (define (range a b) 23 | (unfold ($ >= <> b) id ($ + <> 1) a)) 24 | 25 | (define (polynomial . c) 26 | (lambda (x) 27 | (let loop ([y 0] 28 | [x^n 1] 29 | [c* c]) 30 | (if (null? c*) 31 | y 32 | (loop (+ y (* (car c*) x^n)) 33 | (* x^n x) 34 | (cdr c*)))))) 35 | 36 | (test:unit "higher order functions" 37 | ([f (polynomial 0 10 -1)]) 38 | 39 | (test:that "identity identifies" 40 | (= 42 (id 42)) 41 | (= 2.71828 (id 2.71828)) 42 | (equal? "The Love for Three Oranges" 43 | (id "The Love for Three Oranges")) 44 | (eq? car car) 45 | (not (eq? cons fold-left))) 46 | 47 | (test:that "thunking" 48 | (= 42 ((thunk (* 6 7)))) 49 | (= 0 ((thunk 0)))) 50 | 51 | (test:that "polynomial works" 52 | (= 16 (f 2)) 53 | (= 25 (f 5))) 54 | 55 | (test:that "range works" 56 | (equal? '(0 1 2 3 4) (range 0 5))) 57 | 58 | (test:that "compose" 59 | (= 25 ((compose max <- ($ map f <>)) (range 0 10)))) 60 | 61 | (test:that "splice" 62 | (equal? '(4 -3 9) 63 | ((compose list (splice ($ * <> 4) ($ - <> 5) ($ + <> 6))) 64 | 1 2 3))) 65 | 66 | (test:that "pipe" 67 | (= 25 (pipe (range 0 10) ($ map f <>) <- max)) 68 | (= 7 (pipe (div-and-mod 19 5) +))) 69 | ) 70 | 71 | (test:unit "additional list functions" 72 | ([evens '(2 4 4 6 8 8 10)]) 73 | 74 | (test:that "all?" 75 | (all? even? evens) 76 | (not (all? (lambda (i) (= 0 (mod i 4))) evens))) 77 | 78 | (test:that "unique-sorted removes duplicates" 79 | (equal? (unique-sorted = evens) '(2 4 6 8 10))) 80 | ) 81 | -------------------------------------------------------------------------------- /lyonesse/parsing/ast-builder/simple.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse parsing ast-builder simple) 2 | #|! The simple interface builds an S-expression by composing functions in 3 | | continuation passing style. At each point during the process of building 4 | | the S-expr the builder state is a function of one argument, placing its 5 | | argument in the current position in the S-expr. The returned value may be 6 | | another state function or the resulting nested list. 7 | | 8 | | > (sb:close (sb:start)) 9 | | -> () 10 | | 11 | | > (sb:close (sb:add 4 (sb:add 5 (sb:start)))) 12 | | -> (5 4) 13 | | 14 | | > ((compose sb:close 15 | | (sb:add 4) 16 | | sb:close 17 | | (sb:add 3) 18 | | (sb:add 2) 19 | | sb:new-list 20 | | (sb:add 1) 21 | | sb:start)) 22 | | -> (1 (2 3) 4) 23 | | 24 | | > ((compose sb:close sb:close 25 | | (sb:add #\o) 26 | | (sb:add #\l) 27 | | (sb:add #\l) 28 | | (sb:add #\e) 29 | | (sb:add #\h) 30 | | sb:new-string 31 | | sb:start)) 32 | | -> ("hello") 33 | | 34 | | > ((compose sb:close sb:close 35 | | (sb:add #\a) 36 | | (sb:add #\d) 37 | | (sb:add #\b) 38 | | (sb:add #\m) 39 | | (sb:add #\a) 40 | | (sb:add #\l) 41 | | sb:new-symbol 42 | | sb:start)) 43 | | -> (lambda) 44 | |# 45 | (export sb:start sb:new sb:add sb:close sb:close-all 46 | sb:new-symbol sb:new-string sb:new-list sb:new-datum) 47 | 48 | (import (rnrs base (6)) 49 | (rnrs io ports (6)) 50 | (lyonesse functional)) 51 | 52 | (define (sb:start) 53 | (lambda (x) x)) 54 | 55 | (define (sb:new f state) 56 | (lambda (x) 57 | (lambda (y) 58 | (state (cons (f x) y))))) 59 | 60 | (define sb:new-list 61 | ($ sb:new id <>)) 62 | 63 | (define sb:new-string 64 | ($ sb:new list->string <>)) 65 | 66 | (define sb:new-symbol 67 | ($ sb:new (compose string->symbol list->string) <>)) 68 | 69 | (define (sb:close state) 70 | (state '())) 71 | 72 | (define (sb:close-all state) 73 | (if (procedure? state) 74 | (sb:close-all (state '())) 75 | state)) 76 | 77 | (define sb:new-datum 78 | ($ sb:new (compose get-datum open-string-input-port list->string) <>)) 79 | 80 | (define (sb:add item) 81 | (lambda (state) 82 | (lambda (x) 83 | (state (cons item x))))) 84 | ) 85 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Lyonesse - collection of modules for (Chez) scheme 2 | ================================================== 3 | 4 | This repository now contains these modules: 5 | - testing 6 | - munsch: a numeric library for R6RS scheme. The name is a contraction of Num-eric Sch-eme, 7 | with Num reversed, because we schemers like to. 8 | - yasos 9 | - parsing: currently parses XML, it is trivial to add json, cson, and other formats. 10 | - streams: srfi-41 verbatim. 11 | - match: Pattern matching by Dan Friedman, Erik Hilsdale and Kent Dybvig; verbatim. 12 | - record-with-context: add context management to R6 records, access elements with `with-`, 13 | and update elements (by copy) with `update-`. 14 | - cut: srfi-26 verbatim. 15 | 16 | Prerequisites 17 | ------------- 18 | 19 | A R6RS compatible scheme with a decent set of SRFIs installed; I'm currently using Chez (http://github.com/cisco/chezscheme). Tests also run successfully on Racket. To have them run on Guile, I needed to change '(srfi :48)' into '(ice-9 format)' and it doesn't parse R6RS strings correctly. 20 | 21 | Experiments 22 | ----------- 23 | 24 | - Talking to Gtk3 libraries 25 | 26 | Munsch - Numeric Scheme 27 | ======================= 28 | 29 | Munsch is designed to do fast numerical array routines in a flexible way and 30 | semantic way. I'm currently developing it to interact with OpenGL functions. 31 | 32 | Goals: 33 | - Complete R6RS compliance, based on bytearrays 34 | - Support for extensive slicing and dicing of numeric arrays 35 | - Support for linear algebra 36 | - Support for geometry 37 | 38 | The basis for Munsch is `bytearrays`, on top of which we have a `record-type`s 39 | called `f32vector` and `f32array` (only single precesion for the moment). The 40 | vector type contains a contiguous block of memory, being a simple wrapper 41 | around `bytevector`. The `f32array` type contains slicing information in 42 | addition to a reference to the raw data. A `slice` contains information on 43 | offset, stride, shape and total size of the array. To perform slicing 44 | operations on an array I have defined the `f32array-cut` syntax. 45 | 46 | To perform linear algebra, I defined matrix and vector types for which some of 47 | the well known operations on matrices are defined. These use `f32vector` to 48 | store their memory, and are always contiguous. This is so that we can pass them 49 | to OpenGL routines, but also applications using FFI to LAPACK or GSL come to 50 | mind. 51 | 52 | Next, on top of the linear algebra we can define a vector type that specialises 53 | in geometry operations. This is to provide semantics for vertices, vectors, 54 | polygons etc. 55 | 56 | Licence 57 | ------- 58 | Apache 2.0 59 | 60 | -------------------------------------------------------------------------------- /lyonesse/parsing/xml.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse parsing xml) 2 | (export xml:read xml:from-string 3 | xml:get xml:get-first xml:get-content xml:get* xml:list xml:list* 4 | xml:get-attr) 5 | 6 | (import (rnrs base (6)) 7 | (rnrs lists (6)) 8 | (rnrs io ports (6)) 9 | (lyonesse match) 10 | (lyonesse functional) 11 | (lyonesse parsing xml parser) 12 | (lyonesse parsing xml clean)) 13 | 14 | (define (xml:read filename) 15 | (map xml:clean 16 | (xml:ast-from-port 17 | (open-file-input-port filename 18 | (file-options) 19 | 'line 20 | (native-transcoder))))) 21 | 22 | (define (xml:from-string s) 23 | (map xml:clean (xml:ast-from-port 24 | (open-string-input-port s)))) 25 | 26 | (define (safe-car obj) (and (pair? obj) (car obj))) 27 | (define (safe-cdr obj) (and (pair? obj) (cdr obj))) 28 | 29 | (define (alist? lst) 30 | (and (list? lst) 31 | (all? (lambda (i) (pair? i)) lst))) 32 | 33 | (define (xml:get data . args) 34 | (match args 35 | [(,tag ,attributes) (guard (and (symbol? tag) 36 | (alist? attributes))) 37 | (xml:*get* data tag attributes)] 38 | [(,tag ,attributes ...) (guard (and (symbol? tag) 39 | (alist? attributes))) 40 | (xml:*get* data tag attributes)] 41 | [,x (error 'xml:get "Arguments do not match pattern." args)])) 42 | 43 | (define (xml:*get* data tag attributes) 44 | (filter (lambda (item) 45 | (and (pair? item) 46 | (eq? (car item) tag) 47 | (all? (lambda (attr) 48 | (let ([value (safe-cdr (assq (car attr) (cadr item)))]) 49 | (if (procedure? (cdr attr)) 50 | ((cdr attr) value) 51 | (equal? (cdr attr) value)))) 52 | attributes))) 53 | data)) 54 | 55 | (define xml:get-content 56 | (compose append <- ($ map cddr <>) xml:get)) 57 | 58 | (define xml:get-entries 59 | (compose ($ map (juxt car cadr) <>) xml:get)) 60 | 61 | (define (xml:get* data . query) 62 | (if (null? query) 63 | data 64 | (apply xml:get* 65 | (apply xml:get-content 66 | data (car query)) 67 | (cdr query)))) 68 | 69 | (define xml:get-first 70 | (compose safe-car <- ($ map cddr <>) xml:get)) 71 | 72 | (define (xml:get-attr datum attr) 73 | (safe-cdr (assq attr (cadr datum)))) 74 | 75 | (define (xml:list data . query) 76 | (cond 77 | [(null? query) '()] 78 | [(null? (cdr query)) 79 | (apply xml:get-entries data (car query))] 80 | [else 81 | (apply xml:list (apply xml:get-content data (car query)) (cdr query))])) 82 | 83 | (define (xml:list* data . query) 84 | (cond 85 | [(null? query) data] 86 | [(null? (cdr query)) 87 | (apply xml:get data (car query))] 88 | [else 89 | (apply xml:list* (apply xml:get-content data (car query)) (cdr query))])) 90 | ) 91 | -------------------------------------------------------------------------------- /lyonesse/yasos.scm: -------------------------------------------------------------------------------- 1 | #| Copyright 1992 Ken Dickey, 2016 Johan Hidding 2 | | 3 | | Licensed under the Apache License, Version 2.0 (the "License"); 4 | | you may not use this file except in compliance with the License. 5 | | You may obtain a copy of the License at 6 | | 7 | | http://www.apache.org/licenses/LICENSE-2.0 8 | | 9 | | Unless required by applicable law or agreed to in writing, software 10 | | distributed under the License is distributed on an "AS IS" BASIS, 11 | | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | | See the License for the specific language governing permissions and 13 | | limitations under the License. 14 | |# 15 | 16 | #| YASOS, Ken Dickey's 'Yet Another Scheme Object System'. The original 17 | | paper including most of this source is included in 18 | | 19 | | Ken Dickey, "Scheming with Objects", AI Expert 7(10):24-33, October 1992. 20 | | 21 | | which can be found as `doc/swob.txt` in this distribution. The original 22 | | code is considered to be in the public domain. 23 | |# 24 | 25 | (library (lyonesse yasos) 26 | (export 27 | instance? 28 | define-predicate 29 | define-operation 30 | object 31 | object-with-ancestors 32 | operate-as) 33 | 34 | (import (rnrs (6)) 35 | (rnrs records syntactic (6)) 36 | 37 | (srfi :48)) 38 | 39 | (define-record-type instance 40 | (fields (immutable dispatcher))) 41 | 42 | (define-syntax define-operation 43 | (syntax-rules () 44 | [(_ ( ...) ...) 45 | (define 46 | (letrec [(self (lambda ( ...) 47 | (cond 48 | [(and (instance? ) 49 | ((instance-dispatcher ) self)) 50 | => (lambda (operation) (operation ...))] 51 | [else ...])))] 52 | self))] 53 | 54 | [(_ ( ...)) ; no body 55 | (define-operation ( ...) 56 | (error ' (format #f "Operation not handled: ~s" )))] 57 | )) 58 | 59 | (define-syntax define-predicate 60 | (syntax-rules () 61 | [(_ ) (define-operation ( obj) #f)])) 62 | 63 | (define-syntax object 64 | (syntax-rules () 65 | [(_ (( ...) ...) ...) 66 | (let [(table (list 67 | (cons 68 | (lambda ( ...) ...)) 69 | ...))] 70 | (make-instance 71 | (lambda (operation) 72 | (cond 73 | [(assq operation table) => cdr] 74 | [else #f]))))])) 75 | 76 | (define-syntax object-with-ancestors 77 | (syntax-rules () 78 | [(_ ([ ] ...) ...) 79 | (let ([ ] ...) 80 | (let ([child (object ...)]) 81 | (make-instance 82 | (lambda (operation) 83 | (or ((instance-dispatcher child) operation) 84 | ((instance-dispatcher ) operation) 85 | ...)))))])) 86 | 87 | (define-syntax operate-as 88 | (syntax-rules () 89 | [(_ ...) 90 | (((instance-dispatcher ) ) ...)])) 91 | ) 92 | 93 | -------------------------------------------------------------------------------- /gtk-tutorial/window.scm: -------------------------------------------------------------------------------- 1 | #| Copyright 2016 Johan Hidding 2 | | 3 | | Licensed under the Apache License, Version 2.0 (the "License"); 4 | | you may not use this file except in compliance with the License. 5 | | You may obtain a copy of the License at 6 | | 7 | | http://www.apache.org/licenses/LICENSE-2.0 8 | | 9 | | Unless required by applicable law or agreed to in writing, software 10 | | distributed under the License is distributed on an "AS IS" BASIS, 11 | | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | | See the License for the specific language governing permissions and 13 | | limitations under the License. 14 | |# 15 | 16 | (import (chezscheme)) 17 | 18 | (load-shared-object "libgobject-2.0.so") 19 | (load-shared-object "libgdk-3.so") 20 | (load-shared-object "libgtk-3.so") 21 | 22 | ;;; gtk-application-window 23 | (define gtk-application-window-new 24 | (foreign-procedure "gtk_application_window_new" (iptr) iptr)) 25 | 26 | ;;; gtk-window 27 | (define gtk-window-set-title 28 | (foreign-procedure "gtk_window_set_title" (iptr string) void)) 29 | (define gtk-window-set-default-size 30 | (foreign-procedure "gtk_window_set_default_size" (iptr int int) void)) 31 | 32 | ;;; gtk-widget 33 | (define gtk-widget-show-all 34 | (foreign-procedure "gtk_widget_show_all" (iptr) void)) 35 | 36 | ;;; gtk-application 37 | (define gtk-application-new 38 | (foreign-procedure "gtk_application_new" (string int) iptr)) 39 | (define g-application-run 40 | (foreign-procedure "g_application_run" (iptr int iptr) int)) 41 | 42 | ;;; g-signal 43 | (define g-signal-connect-object 44 | (foreign-procedure "g_signal_connect_object" (iptr string int iptr int) unsigned-long)) 45 | 46 | ;;; g-object 47 | (define g-object-unref 48 | (foreign-procedure "g_object_unref" (iptr) void)) 49 | 50 | 51 | (define (activate gtk-app user-data) 52 | (let ((window (gtk-application-window-new gtk-app))) 53 | (gtk-window-set-title window "Example Window") 54 | (gtk-window-set-default-size window 200 200) 55 | (gtk-widget-show-all window))) 56 | 57 | (define callback 58 | (lambda (p) 59 | (let ([code (foreign-callable p (iptr iptr) void)]) 60 | (lock-object code) 61 | (foreign-callable-entry-point code)))) 62 | 63 | (define (main) 64 | (let ((argc (length (command-line))) 65 | (argv (command-line)) 66 | (app (gtk-application-new "org.gtk.example" 0))) 67 | (g-signal-connect-object app "activate" (callback activate) 0 0) 68 | (g-application-run app 0 0) 69 | (g-object-unref app))) 70 | 71 | (main) 72 | 73 | #| 74 | | #include 75 | | 76 | | static void 77 | | activate (GtkApplication* app, 78 | | gpointer user_data) 79 | | { 80 | | GtkWidget *window; 81 | | 82 | | window = gtk_application_window_new (app); 83 | | gtk_window_set_title (GTK_WINDOW (window), "Window"); 84 | | gtk_window_set_default_size (GTK_WINDOW (window), 200, 200); 85 | | gtk_widget_show_all (window); 86 | | } 87 | | 88 | | int 89 | | main (int argc, 90 | | char **argv) 91 | | { 92 | | GtkApplication *app; 93 | | int status; 94 | | 95 | | app = gtk_application_new ("org.gtk.example", G_APPLICATION_FLAGS_NONE); 96 | | g_signal_connect (app, "activate", G_CALLBACK (activate), NULL); 97 | | status = g_application_run (G_APPLICATION (app), argc, argv); 98 | | g_object_unref (app); 99 | | 100 | | return status; 101 | | } 102 | |# 103 | 104 | -------------------------------------------------------------------------------- /lyonesse/record-with-context.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse record-with-context) 2 | (export define-record-with-context) 3 | 4 | (import (rnrs base (6)) 5 | (rnrs syntax-case (6)) 6 | (rnrs records syntactic (6)) 7 | (only (chezscheme) trace-define-syntax)) 8 | #| Define a syntactic record type and a context manager. A R6RS record type 9 | | comes with accessor functions; for example if we create the record 10 | | `my-vector` containing the fields `x` and `y` we get accessors `my-vector-x` 11 | | and `my-vector-y`. Now if we want to use both values in some context we're 12 | | supoosed to say: 13 | | 14 | | > (define (my-vector-length p) 15 | | (let ([x (my-vector-x p)] 16 | | [y (my-vector-y p)]) 17 | | (sqrt (+ (* x x) (* y y))))) 18 | | 19 | | If records become larger, this `let` statement becomes a bit tedious. We 20 | | rather do something like: 21 | | 22 | | > (define (my-vector-length p) 23 | | (with-my-vector p do 24 | | (sqrt (+ (* x x) (* y y))))) 25 | | 26 | | To make this work, we need to introduce every member of the record type 27 | | into the local environment using `datum->syntax`. The `(... ...)` syntax 28 | | is a quoted form of ellipsis for the innner syntax definition. 29 | | 30 | | Parts of this code were adapted from Dybvig TSLP ed. 4. 31 | |# 32 | (define-syntax define-record-with-context 33 | (lambda (x) 34 | ; Define a new symbol, code from TSPL Chapter 8. 35 | (define gen-id 36 | (lambda (template-id . args) 37 | (datum->syntax template-id 38 | (string->symbol 39 | (apply string-append 40 | (map (lambda (x) 41 | (if (string? x) 42 | x 43 | (symbol->string (syntax->datum x)))) 44 | args)))))) 45 | 46 | (syntax-case x (fields) 47 | [(define-record-with-context (fields ...) ...) 48 | (with-syntax ([with-record (gen-id #' "with-" #')] 49 | [update-record (gen-id #' "update-" #')] 50 | [make-record (gen-id #' "make-" #')] 51 | ; Define the names of member access functions. 52 | [(access ...) (map (lambda (x) 53 | (gen-id x #' "-" x)) 54 | #'( ...))]) 55 | #'(begin 56 | (define-record-type (fields ...) ...) 57 | 58 | (define-syntax with-record 59 | (lambda (x) 60 | (syntax-case x () 61 | [(with-record (... ...)) 62 | (with-syntax ([ (datum->syntax #'with-record ')] 63 | ...) 64 | #'(let ([ (access )] ...) 65 | (... ...)))]))) 66 | 67 | (define-syntax update-record 68 | (lambda (x) 69 | (syntax-case x () 70 | [(update-record (... ...)) 71 | (with-syntax ([ (datum->syntax #'update-record ')] 72 | ...) 73 | #'(let ([ (access )] ...) 74 | (let ( (... ...)) 75 | (make-record ...))))]))) 76 | ))]))) 77 | ) 78 | -------------------------------------------------------------------------------- /lyonesse/munsch/array.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse munsch array) 2 | (export array-type? make-array-type array-type-element-type array-type-length array-set! 3 | array? make-array array-element-type array-data array-offset array-length array-ref 4 | with-array bytearray array->list 5 | 6 | ;;; iterator routines 7 | array-head array-tail array-empty?) 8 | 9 | (import (rnrs (6)) 10 | (lyonesse ranges) 11 | (lyonesse functional) 12 | (lyonesse record-with-context) 13 | (lyonesse munsch private) 14 | 15 | (only (chezscheme) trace-define-syntax)) 16 | 17 | (define-record-type array-type 18 | (parent type) 19 | (fields element-type length) 20 | (protocol 21 | (lambda (new) 22 | (lambda (element-type length) 23 | ((new ; type description 24 | `(array ,(type-repr element-type)) 25 | ; bytesize 26 | (* length (type-bytesize element-type)) 27 | ; getter 28 | (lambda (bv x) 29 | (make-array element-type bv x length)) 30 | ; setter 31 | (lambda (bv x value) 32 | (for-range (lambda (i) 33 | ((type-set! element-type) 34 | bv (+ x (* (type-bytesize element-type) i)) 35 | ((cond 36 | ((vector? value) vector-ref) 37 | ((array? value) array-ref) 38 | ((list? value) list-ref)) 39 | value i))) 40 | length))) 41 | element-type length))))) 42 | 43 | (define-record-with-context array 44 | (fields element-type data offset length)) 45 | 46 | (define (array-head a) 47 | (with-array a 48 | (with-type element-type 49 | (ref data offset)))) 50 | 51 | (define array-tail 52 | (case-lambda 53 | ((a) (array-tail a 1)) 54 | ((a n) 55 | (with-array a 56 | (with-type element-type 57 | (make-array element-type data (+ offset (* n bytesize) (- length n)))))))) 58 | 59 | (define (array-empty? a) 60 | (zero? (array-length a))) 61 | 62 | (define (array-ref a x) 63 | (with-array a 64 | (with-type element-type 65 | (ref data (+ offset (* x bytesize)))))) 66 | 67 | (define (array-set! a x v) 68 | (with-array a 69 | (with-type element-type 70 | (set! data (+ offset (* x bytesize)) v)))) 71 | 72 | (define (array->list a) 73 | (with-array a 74 | (with-type element-type 75 | (map-range 76 | (lambda (i) (ref data (+ offset (* i bytesize)))) 77 | length)))) 78 | 79 | (define-syntax bytearray 80 | (lambda (x) 81 | (syntax-case x () 82 | [(bytearray ...) 83 | (let* ((type-descr (syntax->datum #')) 84 | (type (make-atom-type type-descr)) 85 | (set! (datum->syntax #'bytearray (atom-set! type-descr))) 86 | (bytesize (datum->syntax #'bytearray (atom-size type-descr)))) 87 | 88 | (with-syntax ([ (length #'( ...))] 89 | [ bytesize]) 90 | #`(let* ([d (make-bytevector (* ))]) 91 | #,@(map (lambda (x n) 92 | #`(#,set! d #,(* (type-bytesize type) n) #,x)) 93 | #'( ...) 94 | (iota #')) 95 | (make-array (make-atom-type ') d 0 ))))]))) 96 | ) 97 | -------------------------------------------------------------------------------- /lyonesse/munsch.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse munsch) 2 | (export 3 | #| Byte type system 4 | | ================ 5 | | 6 | | We define a binary type on top of the R6RS bytevectors. Each type has 7 | | a `ref`, `set!` and `bytesize` field. These fields should be overloaded 8 | | in derived record types to represent composable compound types. 9 | | 10 | | The `bytesize` field speaks for itself. The setter and getter method 11 | | should be modelled after the `bytevector-*-ref` and `bytevector-*-set!` 12 | | functions, extending their functionality to compound types. 13 | |# 14 | type type? make-type type-ref type-set! type-bytesize type-repr with-type 15 | 16 | #| Arrays - array datatype 17 | | ======================= 18 | | 19 | | The `array-type` record derives from `type`. 20 | |# 21 | array-type? make-array-type array-type-element-type array-type-length 22 | 23 | #| Arrays - array container 24 | | ------------------------ 25 | | 26 | | Create an array from an element-type, bytevector, offset and length. 27 | | `array` is an immutable data type. 28 | |# 29 | array? make-array array-element-type array-data array-offset array-length 30 | with-array 31 | 32 | #| Arrays - higher level routines 33 | | ------------------------------ 34 | | 35 | | Example, create a single precision array using the `bytearray` syntax 36 | | then convert result back to a list: 37 | | 38 | | > (array->list (a (bytearray f32 (sqrt 2) 22/7))) 39 | | -> (1.4142135381698608 3.142857074737549) 40 | |# 41 | array-ref array-set! bytearray array->list 42 | array-head array-tail array-empty? 43 | 44 | #| Structs 45 | | ======= 46 | | 47 | | From a byte-data point of view, structs are tuples, and in that sense 48 | | very similar to a heterogeneous kind of arrays. The only difference 49 | | is that we name the elements in the structure and generate accessors 50 | | for them. Let's start with a simple example: 51 | | 52 | | > (define-struct point (x f32) (y f32) (z f32)) 53 | | 54 | | This defines a lot of functions and values. 55 | | 56 | | > (type-repr point-x-type) 57 | | -> f32 58 | | > (type-repr point-type) 59 | | -> (struct f32 f32 f32) 60 | | > (define p (make-point)) 61 | | > (point? p) 62 | | -> #t 63 | | > (point-x-set! p (/ (+ (sqrt 5) 1) 2)) 64 | | > (point-x p) 65 | | -> 1.6180340051651 66 | | > (point-y-set! p (/ (- (sqrt 5) 1) 2)) 67 | | > (with-point p 68 | | (/ y (/ 1 x))) 69 | | -> 1.000000036705515 70 | | 71 | | For the moment nested struct definitions have to be defined manually. 72 | | 73 | | > (define-struct color 74 | | (red u8) (green u8) (blue u8) (alpha u8)) 75 | | > (define-struct vertex 76 | | (texture (array f32 2)) 77 | | (color (struct u8 u8 u8 u8)) 78 | | (point (array f32 3))) 79 | | > (define v (make-vertex)) 80 | | > (vertex-color-set! '(255 127 0 255)) ; orange 81 | | > (color-green (vertex-color v)) 82 | | -> 127 83 | | > (color? (vertex-color v)) 84 | | -> #f ; fix me 85 | | 86 | | Also any alignment issues have to be solved by hand. We are limited 87 | | by the fact that the size of `color-type` is not known at the time 88 | | when the `(define-struct vertex ...)` syntax is being expanded. 89 | |# 90 | define-struct) 91 | 92 | (import (rnrs base (6)) 93 | (lyonesse munsch private) 94 | (lyonesse munsch array) 95 | (lyonesse munsch struct)) 96 | ) 97 | -------------------------------------------------------------------------------- /lyonesse/streams/primitive.scm: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) Philip L. Bewig (2007). All Rights Reserved. 2 | ;;; Permission is hereby granted, free of charge, to any person 3 | ;;; obtaining a copy of this software and associated documentation files 4 | ;;; (the "Software"), to deal in the Software without restriction, 5 | ;;; including without limitation the rights to use, copy, modify, merge, 6 | ;;; publish, distribute, sublicense, and/or sell copies of the Software, 7 | ;;; and to permit persons to whom the Software is furnished to do so, 8 | ;;; subject to the following conditions: 9 | ;;; 10 | ;;; The above copyright notice and this permission notice shall be 11 | ;;; included in all copies or substantial portions of the Software. 12 | ;;; 13 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 14 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 15 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 16 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 17 | ;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 18 | ;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 19 | ;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 20 | ;;; SOFTWARE. 21 | 22 | (library (lyonesse streams primitive) 23 | 24 | (export stream-null stream-cons stream? stream-null? stream-pair? 25 | stream-car stream-cdr stream-lambda) 26 | 27 | (import (rnrs base (6)) 28 | (rnrs records syntactic (6)) 29 | (rnrs mutable-pairs (6))) 30 | 31 | (define-record-type (stream-type make-stream stream?) 32 | (fields (mutable box stream-promise stream-promise!))) 33 | 34 | (define-syntax stream-lazy 35 | (syntax-rules () 36 | ((lazy expr) 37 | (make-stream 38 | (cons 'lazy (lambda () expr)))))) 39 | 40 | (define (stream-eager expr) 41 | (make-stream 42 | (cons 'eager expr))) 43 | 44 | (define-syntax stream-delay 45 | (syntax-rules () 46 | ((stream-delay expr) 47 | (stream-lazy (stream-eager expr))))) 48 | 49 | (define (stream-force promise) 50 | (let ((content (stream-promise promise))) 51 | (case (car content) 52 | ((eager) (cdr content)) 53 | ((lazy) (let* ((promise* ((cdr content))) 54 | (content (stream-promise promise))) 55 | (if (not (eqv? (car content) 'eager)) 56 | (begin (set-car! content (car (stream-promise promise*))) 57 | (set-cdr! content (cdr (stream-promise promise*))) 58 | (stream-promise! promise* content))) 59 | (stream-force promise)))))) 60 | 61 | (define stream-null (stream-delay (cons 'stream 'null))) 62 | 63 | (define-record-type (stream-pare-type make-stream-pare stream-pare?) 64 | (fields (immutable kar stream-kar) (immutable kdr stream-kdr))) 65 | 66 | (define (stream-pair? obj) 67 | (and (stream? obj) (stream-pare? (stream-force obj)))) 68 | 69 | (define (stream-null? obj) 70 | (and (stream? obj) 71 | (eqv? (stream-force obj) 72 | (stream-force stream-null)))) 73 | 74 | (define-syntax stream-cons 75 | (syntax-rules () 76 | ((stream-cons obj strm) 77 | (stream-delay (make-stream-pare (stream-delay obj) (stream-lazy strm)))))) 78 | 79 | (define (stream-car strm) 80 | (cond ((not (stream? strm)) (error 'stream-car "non-stream")) 81 | ((stream-null? strm) (error 'stream-car "null stream")) 82 | (else (stream-force (stream-kar (stream-force strm)))))) 83 | 84 | (define (stream-cdr strm) 85 | (cond ((not (stream? strm)) (error 'stream-cdr "non-stream")) 86 | ((stream-null? strm) (error 'stream-cdr "null stream")) 87 | (else (stream-kdr (stream-force strm))))) 88 | 89 | (define-syntax stream-lambda 90 | (syntax-rules () 91 | ((stream-lambda formals body0 body1 ...) 92 | (lambda formals (stream-lazy (let () body0 body1 ...))))))) 93 | -------------------------------------------------------------------------------- /lyonesse/cut.scm: -------------------------------------------------------------------------------- 1 | #| REFERENCE IMPLEMENTATION FOR SRFI-26 "CUT" 2 | | ========================================== 3 | | 4 | | Sebastian.Egner@philips.com, 5-Jun-2002. 5 | | adapted from the posting by Al Petrofsky 6 | | placed in the public domain 7 | | 8 | | The code to handle the variable argument case was originally 9 | | proposed by Michael Sperber and has been adapted to the new 10 | | syntax of the macro using an explicit rest-slot symbol. The 11 | | code to evaluate the non-slots for cute has been proposed by 12 | | Dale Jordan. The code to allow a slot for the procedure position 13 | | and to process the macro using an internal macro is based on 14 | | a suggestion by Al Petrofsky. The code found below is, with 15 | | exception of this header and some changes in variable names, 16 | | entirely written by Al Petrofsky. 17 | | 18 | | compliance: 19 | | Scheme R5RS (including macros). 20 | | 21 | | loading this file into Scheme 48 0.57: 22 | | ,load cut.scm 23 | | 24 | | history of this file: 25 | | SE, 6-Feb-2002: initial version as 'curry' with ". <>" notation 26 | | SE, 14-Feb-2002: revised for <...> 27 | | SE, 27-Feb-2002: revised for 'cut' 28 | | SE, 03-Jun-2002: revised for proc-slot, cute 29 | | SE, 04-Jun-2002: rewritten with internal transformer (no "loop" pattern) 30 | | SE, 05-Jun-2002: replace my code by Al's; substituted "constant" etc. 31 | | to match the convention in the SRFI-document 32 | | 33 | | (srfi-26-internal-cut slot-names combination . se) 34 | | transformer used internally 35 | | slot-names : the internal names of the slots 36 | | combination : procedure being specialized, followed by its arguments 37 | | se : slots-or-exprs, the qualifiers of the macro 38 | |# 39 | 40 | (library (lyonesse cut) 41 | (export cut cute <> <...>) 42 | 43 | (import (rnrs (6)) 44 | (lyonesse aux-keyword)) 45 | 46 | (define-auxiliary-keywords <> <...>) 47 | 48 | (define-syntax srfi-26-internal-cut 49 | (syntax-rules (<> <...>) 50 | 51 | ;; construct fixed- or variable-arity procedure: 52 | ;; (begin proc) throws an error if proc is not an 53 | ((srfi-26-internal-cut (slot-name ...) (proc arg ...)) 54 | (lambda (slot-name ...) ((begin proc) arg ...))) 55 | ((srfi-26-internal-cut (slot-name ...) (proc arg ...) <...>) 56 | (lambda (slot-name ... . rest-slot) (apply proc arg ... rest-slot))) 57 | 58 | ;; process one slot-or-expr 59 | ((srfi-26-internal-cut (slot-name ...) (position ...) <> . se) 60 | (srfi-26-internal-cut (slot-name ... x) (position ... x) . se)) 61 | ((srfi-26-internal-cut (slot-name ...) (position ...) nse . se) 62 | (srfi-26-internal-cut (slot-name ...) (position ... nse) . se)))) 63 | 64 | ; (srfi-26-internal-cute slot-names nse-bindings combination . se) 65 | ; transformer used internally 66 | ; slot-names : the internal names of the slots 67 | ; nse-bindings : let-style bindings for the non-slot expressions. 68 | ; combination : procedure being specialized, followed by its arguments 69 | ; se : slots-or-exprs, the qualifiers of the macro 70 | 71 | (define-syntax srfi-26-internal-cute 72 | (syntax-rules (<> <...>) 73 | 74 | ;; If there are no slot-or-exprs to process, then: 75 | ;; construct a fixed-arity procedure, 76 | ((srfi-26-internal-cute 77 | (slot-name ...) nse-bindings (proc arg ...)) 78 | (let nse-bindings (lambda (slot-name ...) (proc arg ...)))) 79 | ;; or a variable-arity procedure 80 | ((srfi-26-internal-cute 81 | (slot-name ...) nse-bindings (proc arg ...) <...>) 82 | (let nse-bindings (lambda (slot-name ... . x) (apply proc arg ... x)))) 83 | 84 | ;; otherwise, process one slot: 85 | ((srfi-26-internal-cute 86 | (slot-name ...) nse-bindings (position ...) <> . se) 87 | (srfi-26-internal-cute 88 | (slot-name ... x) nse-bindings (position ... x) . se)) 89 | ;; or one non-slot expression 90 | ((srfi-26-internal-cute 91 | slot-names nse-bindings (position ...) nse . se) 92 | (srfi-26-internal-cute 93 | slot-names ((x nse) . nse-bindings) (position ... x) . se)))) 94 | 95 | ; exported syntax 96 | 97 | (define-syntax cut 98 | (syntax-rules () 99 | ((_ . slots-or-exprs) 100 | (srfi-26-internal-cut () () . slots-or-exprs)))) 101 | 102 | (define-syntax cute 103 | (syntax-rules () 104 | ((cute . slots-or-exprs) 105 | (srfi-26-internal-cute () () () . slots-or-exprs)))) 106 | ) 107 | 108 | -------------------------------------------------------------------------------- /lyonesse/munsch/slice.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse munsch slice) 2 | (export slice? make-slice slice-shape slice-stride slice-size slice-offset 3 | slice-index slice-transpose slice-cut slice-reverse 4 | slice-contiguous? with-slice update-slice 5 | 6 | slice-dimension) 7 | 8 | (import (rnrs base (6)) 9 | (rnrs lists (6)) 10 | (rnrs control (6)) 11 | (rnrs records syntactic (6)) 12 | 13 | (lyonesse functional) 14 | (lyonesse record-with-context)) 15 | 16 | #|! Returns a new list where the `n`-th element is changed by mapping it 17 | | through `proc`. 18 | |# 19 | (define (list-mod lst n proc) 20 | (let loop ([lst lst] 21 | [n n] 22 | [result '()]) 23 | (cond 24 | [(null? lst) (reverse result)] 25 | [(zero? n) (loop (cdr lst) -1 (cons (proc (car lst)) result))] 26 | [else (loop (cdr lst) (- n 1) (cons (car lst) result))]))) 27 | 28 | (define (list-del lst n) 29 | (let loop ([lst lst] 30 | [n n] 31 | [result '()]) 32 | (cond 33 | [(null? lst) (reverse result)] 34 | [(zero? n) (loop (cdr lst) (dec n) result)] 35 | [else (loop (cdr lst) (dec n) (cons (car lst) result))]))) 36 | 37 | (define (size-and-stride shape) 38 | (let ([cum-prod (fold-right (lambda (x y) (cons (* x (car y)) y)) 39 | '(1) shape)]) 40 | (values (car cum-prod) (cdr cum-prod)))) 41 | 42 | (define (compute-stride shape) 43 | (let ([cum-prod (fold-right (lambda (x y) (cons (* x (car y)) y)) 44 | '(1) shape)]) 45 | (cdr cum-prod))) 46 | 47 | #| Working with slices =================================================== |# 48 | (define-record-with-context slice 49 | (fields shape stride size offset) 50 | (protocol 51 | (lambda (new) 52 | (case-lambda 53 | [(shape) (let-values ([(size stride) (size-and-stride shape)]) 54 | (new shape stride size 0))] 55 | [(shape stride size offset) (new shape stride size offset)])))) 56 | 57 | (define (slice-dimension s) 58 | (length (slice-shape s))) 59 | 60 | (define (slice-index slice idx) 61 | (with-slice slice 62 | (apply + offset (map * stride idx)))) 63 | 64 | (define (slice-transpose slice) 65 | (make-slice (reverse (slice-shape slice)) 66 | (reverse (slice-stride slice)) 67 | (slice-shape slice) 68 | (slice-offset slice))) 69 | 70 | (define (slice-cut-single slice axis a b step) 71 | (let* ([offset (+ (slice-offset slice) 72 | (* a (list-ref (slice-stride slice) axis)))] 73 | [stride (list-mod (slice-stride slice) axis 74 | ($ * step <>))] 75 | [shape (list-mod (slice-shape slice) axis 76 | (thunk (div (- b a) (abs step))))] 77 | [size (fold-left * 1 shape)]) 78 | (make-slice shape stride size offset))) 79 | 80 | (define (slice-select-single slice axis x) 81 | (with-slice slice 82 | (let* ([offset* (+ offset (* x (list-ref stride axis)))] 83 | [stride* (list-del stride axis)] 84 | [shape* (list-del shape axis)] 85 | [size* (fold-right * 1 shape*)]) 86 | (make-slice shape* stride* size* offset*)))) 87 | 88 | (define-syntax slice-cut-internal 89 | (syntax-rules () 90 | [(_ ) ] 91 | [(_ () ...) 92 | (slice-cut-internal (+ 1 ) ...)] 93 | [(_ ( ) ...) 94 | (slice-cut-internal ( 1) ...)] 95 | [(_ ( ) ...) 96 | (slice-cut-internal 97 | (slice-cut-single ) 98 | (+ 1 ) ...)] 99 | [(_ ...) 100 | (slice-cut-internal 101 | (slice-select-single ) 102 | ...)])) 103 | 104 | (define-syntax slice-cut 105 | (syntax-rules () 106 | [(_ ...) 107 | (slice-cut-internal 0 ...)])) 108 | 109 | (define (slice-reverse slice axis) 110 | (let* ([offset (+ (slice-offset slice) 111 | (* (list-ref (slice-stride slice) axis) 112 | (- (list-ref (slice-shape slice) axis) 1)))] 113 | [stride (list-mod (slice-stride slice) axis ($ * -1 <>))]) 114 | (make-slice (slice-shape slice) stride (slice-size slice) offset))) 115 | 116 | (define (slice-contiguous? slice) 117 | (with-slice slice 118 | (and (zero? offset) (equal? (compute-stride shape) stride)))) 119 | ) 120 | -------------------------------------------------------------------------------- /lyonesse/functional.scm: -------------------------------------------------------------------------------- 1 | #| Copyright 2016 Johan Hidding 2 | | 3 | | Licensed under the Apache License, Version 2.0 (the "License"); 4 | | you may not use this file except in compliance with the License. 5 | | You may obtain a copy of the License at 6 | | 7 | | http://www.apache.org/licenses/LICENSE-2.0 8 | | 9 | | Unless required by applicable law or agreed to in writing, software 10 | | distributed under the License is distributed on an "AS IS" BASIS, 11 | | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | | See the License for the specific language governing permissions and 13 | | limitations under the License. 14 | |# 15 | 16 | (library (lyonesse functional) 17 | (export $ <> <...> id thunk <- args compose splice juxt 18 | flip reverse-args 19 | partial partial* on pipe 20 | any? all? unique-sorted unfold 21 | 22 | inc dec iota receive) 23 | 24 | (import (rnrs (6)) 25 | (only (srfi :1 lists) append-reverse unfold) 26 | (rename (lyonesse cut) (cut $))) 27 | 28 | 29 | (define (inc x) (+ x 1)) 30 | (define (dec x) (- x 1)) 31 | (define (iota n) (unfold ($ = <> n) id inc 0)) 32 | 33 | #| identity function 34 | | @(param x) any value 35 | | @(returns) @(ref x) 36 | |# 37 | (define (id x) x) 38 | 39 | #| creates a thunk 40 | | @(param x) any value 41 | | @(returns) a function returning @(ref x) 42 | |# 43 | (define (thunk x) (lambda _ x)) 44 | 45 | #| forward result as values 46 | | @(param x) a list 47 | | @(returns) values in @(ref x) 48 | |# 49 | (define (<- x) (apply values x)) 50 | 51 | #| make list from values 52 | | @(param . X) variadic list 53 | | @(returns) @(ref X) 54 | |# 55 | (define (args . X) X) 56 | 57 | #| compose functions 58 | | @(param f . rest) variadic list of functions 59 | | @(returns) functional composite of arguments 60 | |# 61 | (define (compose f . rest) 62 | (if (null? rest) 63 | f 64 | (let ((g (apply compose rest))) 65 | (lambda args 66 | (call-with-values ($ apply g args) f))))) 67 | 68 | #| splice 69 | | @(param . F) variadic list of functions 70 | | @(returns) new function returning values for each 71 | | of each n-th argument applied to the n-th function in F 72 | | 73 | | ≪── f₁ ── x₁ ─╮ 74 | | ≪── f₂ ── x₂ ─┼── X 75 | | ≪── f₃ ── x₃ ─╯ 76 | |# 77 | (define (splice . F) 78 | (compose <- ($ map (lambda (f . X) (apply f X)) F <...>) args)) 79 | 80 | #| juxtapose outcomes 81 | | @(param . F) variadic list of functions 82 | | @(returns) function returning list with result for each 83 | | function applied to its arguments 84 | | 85 | | ≪── f₁ ─╮ 86 | | ≪── f₂ ─┼── X 87 | | ≪── f₃ ─╯ 88 | |# 89 | (define (juxt . F) 90 | (lambda X 91 | (map ($ apply <> X) F))) 92 | 93 | #| apply function after transforming (or selecting) the arguments 94 | | @(param f) function (b ...) -> c 95 | | @(param g) function a -> b 96 | | @(returns) function (a ...) -> c 97 | | 98 | | example: suppose we have a type `vector-3` with accessors `get-x` 99 | | `get-y` and `get-z`, and we want to find the maximum over the x-axis, 100 | | then we can say:: 101 | | 102 | | (define max-x (on max get-x)) 103 | |# 104 | (define (on f g) 105 | (lambda X 106 | (apply f (map g X)))) 107 | 108 | (define flip (lambda (f) (lambda (b a) (f a b)))) 109 | 110 | (define (reverse-args f) 111 | (lambda X 112 | (apply f (reverse X)))) 113 | 114 | (define (partial f . X) 115 | (let ((rev (reverse X))) 116 | (lambda Y 117 | (apply f (append-reverse rev Y))))) 118 | 119 | (define (partial* f . X) 120 | (let ((rev (reverse X))) 121 | (lambda (Y) 122 | (apply f (append-reverse rev Y))))) 123 | 124 | (define-syntax pipe 125 | (lambda (x) 126 | (syntax-case x () 127 | [(pipe ) 128 | (syntax )] 129 | [(pipe ...) 130 | (syntax (pipe (call-with-values (lambda () ) ) 131 | ...))]))) 132 | 133 | (define (any? proc lst) 134 | (not (find proc lst))) 135 | 136 | (define (all? proc lst) 137 | (not (find (compose not proc) lst))) 138 | 139 | (define (unique-sorted eq? input) 140 | (if (null? input) 141 | '() 142 | (let loop ([input (cdr input)] 143 | [output (list (car input))]) 144 | (cond 145 | [(null? input) 146 | (reverse output)] 147 | [(eq? (car input) (car output)) 148 | (loop (cdr input) output)] 149 | [else 150 | (loop (cdr input) (cons (car input) output))])))) 151 | 152 | ;;; (srfi :8 receive) 153 | (define-syntax receive 154 | (syntax-rules () 155 | ((receive formals expression body ...) 156 | (call-with-values (lambda () expression) 157 | (lambda formals body ...))))) 158 | ) 159 | 160 | -------------------------------------------------------------------------------- /lyonesse/munsch/geometry.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse munsch geometry) 2 | 3 | (export g:. g:> g:p-x g:p-y g:p-z g:v-x g:v-y g:v-z 4 | g:+ g:- g:dot g:cross g:print g:data g:origin 5 | g:normalize 6 | 7 | g:point->f32array g:f32array->point 8 | g:vector->f32array g:f32array->vector) 9 | 10 | (import (rnrs base (6)) 11 | (rnrs syntax-case (6)) 12 | (rnrs control (6)) 13 | (rnrs records syntactic) 14 | (rnrs bytevectors (6)) 15 | 16 | (srfi :48) 17 | 18 | (lyonesse functional) 19 | (lyonesse ranges) 20 | (lyonesse munsch f32array) 21 | (lyonesse munsch slice) 22 | (lyonesse munsch linear-algebra)) 23 | 24 | (define-record-type (g:point g:make-point g:point?) 25 | (fields data)) 26 | 27 | (define (g:make-vector data) 28 | (make-l:vector 3 data)) 29 | 30 | (define g:vector-data l:vector-data) 31 | 32 | (define (g:vector? v) 33 | (and (l:vector? v) 34 | (= 3 (l:vector-length v)))) 35 | 36 | (define (g:data p) 37 | (cond 38 | [(g:point? p) (g:point-data p)] 39 | [(g:vector? p) (g:vector-data p)])) 40 | 41 | (define (g:point->f32array p) 42 | (make-f32array (make-slice '(3)) (g:point-data p))) 43 | 44 | (define (g:f32array->point a) 45 | (with-f32array a 46 | (unless (= 1 (slice-dimension slice)) 47 | (error 'g:f32array->point "Array should be one-dimensional." a)) 48 | (with-slice slice 49 | (g:make-point (f32array-copy-data a))))) 50 | 51 | (define g:f32array->vector f32array->l:vector) 52 | (define g:vector->f32array l:vector->f32array) 53 | 54 | (define (g:. x y z) 55 | (g:make-point (f32v x y z))) 56 | 57 | (define (g:> x y z) 58 | (g:make-vector (f32v x y z))) 59 | 60 | (define (g:p-x p) (f32vector-ref (g:point-data p) 0)) 61 | (define (g:p-y p) (f32vector-ref (g:point-data p) 1)) 62 | (define (g:p-z p) (f32vector-ref (g:point-data p) 2)) 63 | 64 | (define (g:v-x p) (f32vector-ref (g:vector-data p) 0)) 65 | (define (g:v-y p) (f32vector-ref (g:vector-data p) 1)) 66 | (define (g:v-z p) (f32vector-ref (g:vector-data p) 2)) 67 | 68 | (define (g:print v) 69 | (cond 70 | [(g:vector? v) (format #t "[> ~a ~a ~a]" 71 | (g:v-x v) (g:v-y v) (g:v-z v))] 72 | [(g:point? v) (format #t "[. ~a ~a ~a]" 73 | (g:p-x v) (g:p-y v) (g:p-z v))])) 74 | 75 | (define (g:* a b) 76 | (cond 77 | [(and (number? a) (g:vector? b)) 78 | (g:make-vector (f32vector-map ($ * <> a) (g:vector-data b)))] 79 | [(and (number? b) (g:vector? a)) 80 | (g:make-vector (f32vector-map ($ * <> b) (g:vector-data a)))] 81 | [else (error 'g:* "Type error: need a vector and a scalar." a b)])) 82 | 83 | (define g:origin 84 | (g:. 0 0 0)) 85 | 86 | (define g:- 87 | (case-lambda 88 | [(a) (cond 89 | [(g:vector? a) 90 | (g:make-vector (f32vector-map - (g:vector-data a)))] 91 | [else (error 'g:- "Type error: need a vector." a)])] 92 | 93 | [(a b) (cond 94 | [(and (g:point? a) (g:point? b)) 95 | (g:make-vector (f32vector-map - (g:point-data a) 96 | (g:point-data b)))] 97 | 98 | [(and (g:point? a) (g:vector? b)) 99 | (g:make-point (f32vector-map - (g:point-data a) 100 | (g:vector-data b)))] 101 | 102 | [(and (g:vector? a) (g:vector? b)) 103 | (g:make-vector (f32vector-map - (g:vector-data a) 104 | (g:vector-data b)))] 105 | 106 | [else (error 'g:- "Type error: need point and point 107 | or vector and vector." a b)])])) 108 | 109 | (define (g:+ a b) 110 | (cond 111 | [(and (g:point? a) (g:vector? b)) 112 | (g:make-point (f32vector-map + (g:point-data a) 113 | (g:vector-data b)))] 114 | 115 | [(and (g:vector? a) (g:vector? b)) 116 | (g:make-vector (f32vector-map + (g:vector-data a) 117 | (g:vector-data b)))] 118 | 119 | [else (error 'g:+ "Type error: need point and vector 120 | or vector and vector." a b)])) 121 | 122 | (define (g:dot a b) 123 | (if (and (g:vector? a) (g:vector? b)) 124 | (f32vector-reduce + 0 (f32vector-map * (g:vector-data a) 125 | (g:vector-data b))) 126 | (error 'g:dot "Type error: Need two vectors." a b))) 127 | 128 | (define (g:cross a b) 129 | (if (and (g:vector? a) (g:vector? b)) 130 | (g:> (- (* (g:v-y a) (g:v-z b)) (* (g:v-z a) (g:v-y b))) 131 | (- (* (g:v-z a) (g:v-x b)) (* (g:v-x a) (g:v-z b))) 132 | (- (* (g:v-x a) (g:v-y b)) (* (g:v-y a) (g:v-x b)))) 133 | (error 'g:cross "Type error: Need two vectors." a b))) 134 | 135 | (define (g:normalize v) 136 | (g:* (/ 1 (sqrt (g:dot v v))) v)) 137 | ) 138 | -------------------------------------------------------------------------------- /lyonesse/munsch/struct.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse munsch struct) 2 | 3 | (export define-struct) 4 | 5 | (import (rnrs (6)) 6 | (lyonesse munsch private) 7 | (lyonesse match) 8 | (lyonesse munsch array) 9 | (lyonesse record-with-context) 10 | 11 | (only (chezscheme) trace-define-syntax)) 12 | 13 | (define-record-with-context struct 14 | (fields type-record data offset)) 15 | 16 | (define-record-type struct-type 17 | (parent type) 18 | (fields type-list) 19 | (protocol 20 | (lambda (new) 21 | (lambda (type-list) 22 | ((new ; type description 23 | `(struct ,@(map type-repr type-list)) 24 | ; bytesize 25 | (apply + (map type-bytesize type-list)) 26 | ; getter 27 | (lambda (bv x) 28 | (make-struct type-list bv x)) 29 | ; setter 30 | (lambda (bv x value-list) 31 | (let loop ((type-list type-list) 32 | (value-list value-list) 33 | (offset x)) 34 | (unless (null? type-list) 35 | (with-type (car type-list) 36 | (set! bv offset (car value-list)) 37 | (loop (cdr type-list) (cdr value-list) (+ offset bytesize))))))) 38 | type-list))))) 39 | 40 | (define (gen-type type) 41 | (match type 42 | ((array ,type ,len) (make-array-type (gen-type type) len)) 43 | ((struct ,types ...) (make-struct-type (map gen-type types))) 44 | (,type (make-atom-type type)))) 45 | 46 | (trace-define-syntax define-struct 47 | (lambda (x) 48 | (define (cumsum lst) 49 | (reverse 50 | (cdr 51 | (fold-left 52 | (lambda (lst x) (cons (+ x (car lst)) lst)) 53 | '(0) lst)))) 54 | 55 | (syntax-case x () 56 | ((define-struct ( ) ...) 57 | 58 | (let* (;(type-list (map gen-type (syntax->datum #'( ...)))) 59 | ;(size-lst (map type-bytesize type-list)) 60 | (size-lst (map gen-size (syntax->datum #'( ...)))) 61 | (bytesize (apply + size-lst)) 62 | ( (datum->syntax #'define-struct (apply + size-lst))) 63 | (offsets (datum->syntax #'define-struct (cumsum size-lst)))) 64 | 65 | (with-syntax ([ (gen-id #' "with-" #')] 66 | [ (gen-id #' "make-" #')] 67 | [ (gen-id #' #' "?")] 68 | [ (gen-id #' #' "-type")] 69 | 70 | [( ...) offsets] 71 | 72 | ; Each field has an offset within the struct 73 | [( ...) (map (lambda (x) 74 | (gen-id x #' "-" x "-type")) 75 | #'( ...))] 76 | 77 | ; Define the names of member access functions. 78 | [( ...) (map (lambda (x) 79 | (gen-id x #' "-" x)) 80 | #'( ...))] 81 | ; Define names of the setter functions. 82 | [( ...) (map (lambda (x) 83 | (gen-id x #' "-" x "-set!")) 84 | #'( ...))]) 85 | #`(begin 86 | (define 87 | (gen-type ')) ... 88 | 89 | (define 90 | (make-struct-type (map gen-type '( ...)))) 91 | 92 | (define 93 | (case-lambda 94 | (() ( 1)) 95 | ((n) (make-struct (make-bytevector (* n #,bytesize)) 0)) 96 | ((d o) (make-struct d o)))) 97 | 98 | (define ( o) 99 | (and (struct? o) (eq? (struct-type-record o)))) 100 | 101 | (define ( s) 102 | (with-type 103 | (with-struct s 104 | (ref data (+ offset ))))) ... 105 | 106 | (define ( s v) 107 | (with-type 108 | (with-struct s 109 | (set! data (+ offset ) v)))) ... 110 | 111 | (define-syntax 112 | (lambda (x) 113 | (syntax-case x () 114 | [( (... ...)) 115 | (with-syntax ([ (datum->syntax #' ')] 116 | ...) 117 | #'(let ([ ( )] ...) 118 | (... ...)))]))) 119 | )) 120 | ))))) 121 | ) 122 | -------------------------------------------------------------------------------- /lyonesse/munsch/private.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse munsch private) 2 | (export type type? make-type type-ref type-set! type-bytesize type-repr with-type 3 | atom-ref atom-set! 4 | atom-type? make-atom-type 5 | atom-size gen-size gen-id) 6 | 7 | (import (rnrs base (6)) 8 | (rnrs lists (6)) 9 | (rnrs bytevectors (6)) 10 | (rnrs syntax-case (6)) 11 | (rnrs records syntactic (6)) 12 | 13 | (lyonesse record-with-context) 14 | (lyonesse match)) 15 | 16 | #| Atomic data access routines, used in syntactic type building ========== |# 17 | (define (atom-set! symb) 18 | (let ((x (assq symb '((f32 . bytevector-ieee-single-native-set!) 19 | (f64 . bytevector-ieee-double-native-set!) 20 | (u8 . bytevector-u8-set!) 21 | (u16 . bytevector-u16-native-set!) 22 | (u32 . bytevector-u32-native-set!) 23 | (u64 . bytevector-u64-native-set!) 24 | (s8 . bytevector-s8-set!) 25 | (s16 . bytevector-s16-native-set!) 26 | (s32 . bytevector-s32-native-set!) 27 | (s64 . bytevector-s64-native-set!))))) 28 | (and x (cdr x)))) 29 | 30 | (define (atom-ref symb) 31 | (let ((x (assq symb '((f32 . bytevector-ieee-single-native-ref) 32 | (f64 . bytevector-ieee-double-native-ref) 33 | (u8 . bytevector-u8-ref) 34 | (u16 . bytevector-u16-native-ref) 35 | (u32 . bytevector-u32-native-ref) 36 | (u64 . bytevector-u64-native-ref) 37 | (s8 . bytevector-s8-ref) 38 | (s16 . bytevector-s16-native-ref) 39 | (s32 . bytevector-s32-native-ref) 40 | (s64 . bytevector-s64-native-ref))))) 41 | (and x (cdr x)))) 42 | 43 | #| Atomic data access routines, used in `soft' data types ================ |# 44 | (define (atom-set!-fn symb) 45 | (let ((x (assq symb `((f32 . ,bytevector-ieee-single-native-set!) 46 | (f64 . ,bytevector-ieee-double-native-set!) 47 | (u8 . ,bytevector-u8-set!) 48 | (u16 . ,bytevector-u16-native-set!) 49 | (u32 . ,bytevector-u32-native-set!) 50 | (u64 . ,bytevector-u64-native-set!) 51 | (s8 . ,bytevector-s8-set!) 52 | (s16 . ,bytevector-s16-native-set!) 53 | (s32 . ,bytevector-s32-native-set!) 54 | (s64 . ,bytevector-s64-native-set!))))) 55 | (and x (cdr x)))) 56 | 57 | (define (atom-ref-fn symb) 58 | (let ((x (assq symb `((f32 . ,bytevector-ieee-single-native-ref) 59 | (f64 . ,bytevector-ieee-double-native-ref) 60 | (u8 . ,bytevector-u8-ref) 61 | (u16 . ,bytevector-u16-native-ref) 62 | (u32 . ,bytevector-u32-native-ref) 63 | (u64 . ,bytevector-u64-native-ref) 64 | (s8 . ,bytevector-s8-ref) 65 | (s16 . ,bytevector-s16-native-ref) 66 | (s32 . ,bytevector-s32-native-ref) 67 | (s64 . ,bytevector-s64-native-ref))))) 68 | (and x (cdr x)))) 69 | 70 | #| The representation of a type in this struct needs a type 71 | | representation in symbols, a bytesize, a ref function and 72 | | a set! function. The ref function takes arguments of 73 | | bytevector and offset, the set! function takes bytevector 74 | | offset and value. 75 | |# 76 | (define-record-with-context type 77 | (fields repr bytesize ref set!)) 78 | 79 | (define-record-type atom-type 80 | (parent type) 81 | (protocol 82 | (lambda (new) 83 | (lambda (symb) 84 | ((new symb (atom-size symb) 85 | (atom-ref-fn symb) (atom-set!-fn symb))))))) 86 | 87 | #| Compute sizes of syntactic data structures ============================ |# 88 | (define (atom-size symb) 89 | (let ((x (assq symb '(( u8 . 1) ( s8 . 1) 90 | (u16 . 2) (s16 . 2) 91 | (u32 . 4) (s32 . 4) 92 | (u64 . 8) (s64 . 8) 93 | (f32 . 4) (f64 . 8))))) 94 | (and x (cdr x)))) 95 | 96 | (define (gen-size type) 97 | (match type 98 | ((array ,type ,len) (* len (gen-size type))) 99 | ((struct ,types ...) (apply + (map gen-size types))) 100 | (,type (atom-size type)))) 101 | 102 | #| Generate identifier from syntactic components ========================= |# 103 | (define gen-id 104 | (lambda (template-id . args) 105 | (datum->syntax template-id 106 | (string->symbol 107 | (apply string-append 108 | (map (lambda (x) 109 | (if (string? x) 110 | x 111 | (symbol->string (syntax->datum x)))) 112 | args)))))) 113 | ) 114 | -------------------------------------------------------------------------------- /lyonesse/munsch/nd-range.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse munsch nd-range) 2 | 3 | (export make-nd-range nd-range? 4 | nd-range-offset nd-range-index 5 | nd-range-shape nd-range-carry 6 | nd-range-end? nd-range-step) 7 | 8 | (import (rnrs base (6)) 9 | (rnrs lists (6)) 10 | (rnrs control (6)) 11 | (rnrs records syntactic (6)) 12 | 13 | (lyonesse functional) 14 | (lyonesse record-with-context)) 15 | 16 | #|! Not equal to, really this should be in the standard. 17 | |# 18 | (define /= (compose not =)) 19 | 20 | #|! Append two lists, reversing the first one. 21 | | 22 | | > (reverse-append '(3 2 1) (4 5 6)) 23 | | -> (1 2 3 4 5 6) 24 | |# 25 | (define (reverse-append rev lst) 26 | (if (null? rev) 27 | lst 28 | (reverse-append (cdr rev) (cons (car rev) lst)))) 29 | 30 | #|! Compute the default strides for a shape. 31 | | 32 | | > (compute-stride '(3 4 5)) 33 | | -> (20 5 1) 34 | |# 35 | (define (compute-stride shape) 36 | (let ([cum-prod (fold-right (lambda (x y) (cons (* x (car y)) y)) 37 | '(1) shape)]) 38 | (cdr cum-prod))) 39 | 40 | #|! Compute the carry, which is the step between the end of 41 | | a row and the begining of the next one. 42 | | 43 | | > (compute-carry '(3 76 2)) 44 | | -> (1 0 0) 45 | | 46 | | > (compute-carry '(3 4 5) '(2 12 96)) 47 | | -> (2 6 48) 48 | |# 49 | (define compute-carry 50 | (case-lambda 51 | [(shape) (compute-carry shape (compute-stride shape))] 52 | [(shape stride) 53 | (let loop ([carry (list (car (reverse stride)))] 54 | [shape (reverse shape)] 55 | [stride (reverse stride)]) 56 | (if (null? (cdr stride)) 57 | carry 58 | (loop (cons (- (cadr stride) (* (car stride) (car shape))) 59 | carry) 60 | (cdr shape) (cdr stride))))])) 61 | 62 | #|! The nd-range record contains information for doing walks in arrays. 63 | | 64 | | We define three constructors: 65 | | `(make-nd-range shape)`: sets the iterator on the beginning of a 66 | | contiguous array of the given shape. 67 | | `(make-nd-range offset shape stride)`: sets the iterator on the 68 | | beginning of a previously sliced array. 69 | | `(make-nd-range offset index shape carry)`: the "naked" constructor, 70 | | used in each iteration step. 71 | | 72 | | Fields: 73 | | `offset`: linear (flat) offset within an array. 74 | | `index`: N-d index. 75 | | `shape`: size of the array in each dimension. 76 | | `carry`: the step between the end on each axis and the beginning of the 77 | | next, i.e. when a digit in the index reaches the value given in 78 | | `shape`, it is set back to 0, and the `carry` is added as an extra to 79 | | the `offset`. 80 | |# 81 | (define-record-with-context nd-range 82 | (fields offset index shape carry) 83 | 84 | (protocol 85 | (lambda (new) 86 | (case-lambda 87 | [(shape) (new 0 (map (thunk 0) shape) shape 88 | (compute-carry shape))] 89 | [(offset shape stride) (new offset (map (thunk 0) shape) shape 90 | (compute-carry shape stride))] 91 | [(offset index shape carry) 92 | (new offset index shape carry)])))) 93 | 94 | #|! Checks if an iterator reached the end of the array. The `nd-range-step` 95 | | function sets the `offset` field to `#xffffffff` when this happens. 96 | |# 97 | (define (nd-range-end? n) 98 | (= (nd-range-offset n) #xffffffff)) 99 | 100 | #|! Move one step in a N-dimensional space. This can be used to do rather 101 | | involved iterations on N-dimensional arrays. 102 | | 103 | | > (unfold nd-range-end? 104 | | nd-range-index 105 | | nd-range-step 106 | | (make-nd-range '(2 2))) 107 | | -> ((0 0) (0 1) (1 0) (1 1)) 108 | | 109 | | > (unfold nd-range-end? 110 | | nd-range-offset 111 | | nd-range-step 112 | | (make-nd-range 1 '(2 3) '(6 2))) 113 | | -> (1 2 5 7 9 11) 114 | |# 115 | (define (nd-range-step n) 116 | (with-nd-range n 117 | (let loop ([offset (+ offset (car (reverse carry)))] 118 | [lo-index (list (inc (car (reverse index))))] 119 | [hi-index (cdr (reverse index))] 120 | [shape* (reverse shape)] 121 | [carry* (cdr (reverse carry))]) 122 | (cond 123 | ; we did not move past the end on this axis 124 | [(/= (car lo-index) 125 | (car shape*)) (make-nd-range offset 126 | (reverse-append hi-index lo-index) 127 | shape carry)] 128 | ; we moved pased the end of the array, set offset to FFFFFFFF 129 | [(null? hi-index) (make-nd-range #xffffffff 130 | (reverse-append hi-index lo-index) 131 | shape carry)] 132 | ; we moved past the end of an axis. 133 | [else (loop (+ offset (car carry*)) 134 | `(,(inc (car hi-index)) 0 . ,(cdr lo-index)) 135 | (cdr hi-index) (cdr shape*) (cdr carry*))])))) 136 | ) 137 | -------------------------------------------------------------------------------- /lyonesse/munsch/array.old.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse munsch array) 2 | 3 | (export make-array array? array-slice array-data array-type 4 | make-slice slice? slice-shape slice-stride slice-size slice-offset 5 | vector->array array->vector array-ref array-iterator 6 | array-set! array-shape array-data-ptr array-byte-size) 7 | 8 | (import (rnrs base (6)) 9 | (rnrs lists (6)) 10 | (rnrs control (6)) 11 | (rnrs records syntactic (6)) 12 | (rnrs io simple (6)) 13 | 14 | (only (srfi :1) unfold) 15 | 16 | (lyonesse functional) 17 | (lyonesse munsch nd-range) 18 | 19 | (lyonesse malloc) 20 | 21 | (only (chezscheme) foreign-ref foreign-set! foreign-sizeof 22 | unbox)) 23 | 24 | #|! Returns a new list where the `n`-th element is changed by mapping it 25 | | through `proc`. 26 | |# 27 | (define (list-mod lst n proc) 28 | (let loop ([lst lst] 29 | [n n] 30 | [result '()]) 31 | (cond 32 | [(null? lst) (reverse result)] 33 | [(zero? n) (loop (cdr lst) -1 (cons (proc (car lst)) result))] 34 | [else (loop (cdr lst) (- n 1) (cons (car lst) result))]))) 35 | 36 | #| Array helper routines ================================================= |# 37 | (define (data-alloc type n) 38 | (malloc (* n (foreign-sizeof type)))) 39 | 40 | (define (data-ref type data pos) 41 | (foreign-ref type (unbox data) (* (foreign-sizeof type) pos))) 42 | 43 | (define (data-set! type data pos value) 44 | (foreign-set! type (unbox data) (* (foreign-sizeof type) pos) value)) 45 | 46 | (define (size-and-stride shape) 47 | (let ([cum-prod (fold-right (lambda (x y) (cons (* x (car y)) y)) 48 | '(1) shape)]) 49 | (values (car cum-prod) (cdr cum-prod)))) 50 | 51 | (define (compute-stride shape) 52 | (let ([cum-prod (fold-right (lambda (x y) (cons (* x (car y)) y)) 53 | '(1) shape)]) 54 | (cdr cum-prod))) 55 | 56 | #| Working with slices =================================================== |# 57 | (define-record-type slice 58 | (fields shape stride size offset) 59 | (protocol 60 | (lambda (new) 61 | (case-lambda 62 | [(shape) (let-values ([(size stride) (size-and-stride shape)]) 63 | (new shape stride size 0))] 64 | [(shape stride size offset) (new shape stride size offset)])))) 65 | 66 | (define (slice-index slice idx) 67 | (fold-left (lambda (sum x y) (+ sum (* x y))) 68 | (slice-offset slice) 69 | (slice-stride slice) 70 | idx)) 71 | 72 | (define (slice-transpose slice) 73 | (make-slice (reverse (slice-shape slice)) 74 | (reverse (slice-stride slice)) 75 | (slice-shape slice) 76 | (slice-offset slice))) 77 | 78 | (define (slice-cut slice axis a b step) 79 | (let* ([offset (+ (slice-offset slice) 80 | (* a (list-ref (slice-stride slice) axis)))] 81 | [stride (list-mod (slice-stride slice) axis 82 | ($ * step <>))] 83 | [shape (list-mod (slice-shape slice) axis 84 | (thunk (div (- b a) (abs step))))] 85 | [size (fold-left * 1 shape)]) 86 | (make-slice shape stride size offset))) 87 | 88 | (define (slice-reverse slice axis) 89 | (let* ([offset (+ (slice-offset slice) 90 | (* (list-ref (slice-stride slice) axis) 91 | (- (list-ref (slice-shape slice) axis) 1)))] 92 | [stride (list-mod (slice-stride slice) axis ($ * -1 <>))]) 93 | (make-slice (slice-shape slice) stride (slice-size slice) offset))) 94 | 95 | 96 | #| Array routines ======================================================== |# 97 | (define-record-type array 98 | (fields type slice data) 99 | 100 | (protocol 101 | (lambda (new) 102 | (case-lambda 103 | [(type shape) (let ([slice (make-slice shape)]) 104 | (new type slice (data-alloc type (slice-size slice))))] 105 | [(type slice data) (new type slice data)])))) 106 | 107 | (define (array-ref a i) 108 | (data-ref (array-type a) (array-data a) 109 | (if (nd-range? i) (nd-range-offset i) i))) 110 | 111 | (define (array-set! a offset value) 112 | (data-set! (array-type a) (array-data a) offset value)) 113 | 114 | (define (array-data-ptr a) 115 | (unbox (array-data a))) 116 | 117 | (define (array-byte-size a) 118 | (* (foreign-sizeof (array-type a)) (slice-size (array-slice a)))) 119 | 120 | (define (array-shape a) 121 | (slice-shape (array-slice a))) 122 | 123 | (define (array-iterator a) 124 | (let ([s (array-slice a)]) 125 | (make-nd-range (slice-offset s) (slice-shape s) (slice-stride s)))) 126 | 127 | (define (vector-match-shape? vec shape) 128 | (cond 129 | [(and (null? shape) (not (vector? vec))) #t] 130 | [(not (vector? vec)) #f] 131 | [(= (vector-length vec) (car shape)) 132 | (for-all (compose ($ vector-match-shape? <> (cdr shape)) 133 | ($ vector-ref vec <>)) 134 | (iota (car shape)))] 135 | [else #f])) 136 | 137 | (define (vector->array type vec) 138 | (let ([shape (unfold (compose not vector?) vector-length 139 | ($ vector-ref <> 0) vec)]) 140 | (when (not (vector-match-shape? vec shape)) 141 | (error 'vector->array "Vector is not uniform." vec)) 142 | 143 | (letrec ([a (make-array type shape)] 144 | [copy! (lambda (r v) 145 | (if (vector? v) 146 | (let loop ([r r] [i 0]) 147 | (if (= i (vector-length v)) 148 | r 149 | (loop (copy! r (vector-ref v i)) (+ i 1)))) 150 | (begin 151 | (array-set! a r v) (+ r 1))))]) 152 | (copy! 0 vec) 153 | a))) 154 | 155 | (define (array->vector a) 156 | (letrec ([vec (make-vector (car (array-shape a)))] 157 | [copy! (lambda (r v s) 158 | (let loop ([r r] [i 0]) 159 | (if (= i (car s)) 160 | r 161 | (if (null? (cdr s)) 162 | (begin 163 | (vector-set! v i (array-ref a r)) 164 | (loop (nd-range-step r) (+ i 1))) 165 | (begin 166 | (vector-set! v i (make-vector (cadr s))) 167 | (loop (copy! r (vector-ref v i) (cdr s)) (+ i 1)))))))]) 168 | (copy! (array-iterator a) vec (array-shape a)) 169 | vec)) 170 | ) 171 | 172 | 173 | -------------------------------------------------------------------------------- /lyonesse/munsch/f32array.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse munsch f32array) 2 | 3 | (export make-f32vector f32vector-map f32vector-reduce 4 | f32vector-set! f32vector-ref f32v 5 | 6 | make-f32array f32array? f32array-slice f32array-data with-f32array update-f32array 7 | make-slice slice? slice-shape slice-stride slice-size slice-offset 8 | f32array-ref f32array-refx f32array-iterator 9 | 10 | f32array-set! f32array-shape f32array-bytesize 11 | 12 | ;;; copying for reuse 13 | f32array-copy-data 14 | 15 | ;;; setters 16 | f32array-copy! f32array-setx! 17 | 18 | ;;; syntax helpers 19 | f32a f32array-cut 20 | 21 | ;;; formated output 22 | f32array-format print-f32array) 23 | 24 | (import (rnrs base (6)) 25 | (rnrs syntax-case (6)) 26 | (rnrs lists (6)) 27 | (rnrs bytevectors (6)) 28 | (rnrs control (6)) 29 | (rnrs records syntactic (6)) 30 | (rnrs io simple (6)) 31 | 32 | (only (srfi :1) unfold) 33 | 34 | (lyonesse functional) 35 | (lyonesse strings) 36 | (lyonesse ranges) 37 | (lyonesse record-with-context) 38 | (lyonesse munsch nd-range) 39 | (lyonesse munsch slice)) 40 | 41 | #| Array helper routines ================================================= |# 42 | (define bv-sp-ref bytevector-ieee-single-native-ref) 43 | (define bv-sp-set! bytevector-ieee-single-native-set!) 44 | 45 | (define (make-f32vector n) 46 | (make-bytevector (* n 4))) 47 | 48 | (define (f32vector-ref data i) 49 | (bv-sp-ref data (* i 4))) 50 | 51 | (define (f32vector-set! data i value) 52 | (bv-sp-set! data (* i 4) value)) 53 | 54 | (define-syntax f32v 55 | (lambda (x) 56 | (syntax-case x () 57 | [(_ ...) 58 | (with-syntax ([ (length #'( ...))]) 59 | #`(let* ([d (make-bytevector (* 4 ))]) 60 | #,@(map (lambda (x n) 61 | #`(bv-sp-set! d #,(* 4 n) #,x)) 62 | #'( ...) 63 | (iota #')) 64 | d))]))) 65 | 66 | (define (f32vector-map f . args) 67 | (let* ([n (bytevector-length (car args))] 68 | [c (make-bytevector n)]) 69 | (for-range (lambda (i) 70 | (bv-sp-set! c i (apply f (map ($ bv-sp-ref <> i) args)))) 71 | 0 n 4) 72 | c)) 73 | 74 | (define (f32vector-reduce f start a) 75 | (let ([n (bytevector-length a)]) 76 | (reduce-range (lambda (start i) 77 | (f start (bv-sp-ref a i))) 78 | 0 0 n 4))) 79 | 80 | #| Array routines ======================================================== |# 81 | (define-record-with-context f32array 82 | (fields slice data) 83 | 84 | (protocol 85 | (lambda (new) 86 | (case-lambda 87 | [(shape) (let ([slice (make-slice shape)]) 88 | (new slice (make-f32vector (slice-size slice))))] 89 | [(slice data) (new slice data)])))) 90 | 91 | (define (f32array-dimension a) 92 | (length (f32array-shape a))) 93 | 94 | (define (f32array-format a) 95 | (if (= 1 (f32array-dimension a)) 96 | (string-append 97 | "[" (string-join 98 | " " (map-range (lambda (i) 99 | (number->string 100 | (f32array-refx a (i)))) 101 | (car (f32array-shape a)))) 102 | "]") 103 | (string-append 104 | "[" (string-join 105 | "\n " (map-range (lambda (i) 106 | (f32array-format 107 | (f32array-cut a i))) 108 | (car (f32array-shape a)))) 109 | "]"))) 110 | 111 | (define (print-f32array a) 112 | (display (f32array-format a))) 113 | 114 | (define-syntax f32array-cut 115 | (syntax-rules () 116 | [(_ ...) 117 | (with-f32array 118 | (make-f32array (slice-cut slice ...) data))])) 119 | 120 | (define (f32array-ref a i) 121 | (f32vector-ref (f32array-data a) 122 | (if (nd-range? i) (nd-range-offset i) i))) 123 | 124 | (define-syntax f32array-refx 125 | (syntax-rules () 126 | [(_ ( ...)) 127 | (with-f32array 128 | (f32vector-ref data (slice-index slice (list ...))))])) 129 | 130 | (define (f32array-set! a offset value) 131 | (f32vector-set! (f32array-data a) offset value)) 132 | 133 | (define (f32array-data-ptr a) 134 | (f32array-data a)) 135 | 136 | (define (f32array-bytesize a) 137 | (* 4 (slice-size (f32array-slice a)))) 138 | 139 | (define (f32array-shape a) 140 | (slice-shape (f32array-slice a))) 141 | 142 | (define (f32array-stride a) 143 | (slice-stride (f32array-slice a))) 144 | 145 | (define (f32array-iterator a) 146 | (let ([s (f32array-slice a)]) 147 | (make-nd-range (slice-offset s) (slice-shape s) (slice-stride s)))) 148 | 149 | (define (f32array-copy-data a) 150 | (let ([data (make-bytevector (f32array-bytesize a))]) 151 | (let loop ([i (f32array-iterator a)] 152 | [j 0]) 153 | (unless (nd-range-end? i) 154 | (f32vector-set! data j 155 | (f32vector-ref (f32array-data a) (nd-range-offset i))) 156 | (loop (nd-range-step i) (inc j)))))) 157 | 158 | (define-syntax f32array-setx! 159 | (syntax-rules () 160 | [(_ ( ...) ) 161 | (with-f32array 162 | (f32vector-set! data (slice-index slice (list ...)) ))])) 163 | 164 | (define (f32array-copy! src tgt) 165 | (unless ((on equal? f32array-shape) src tgt) 166 | (error 'f32array-copy! "Array shapes do not match." src tgt)) 167 | 168 | (let ([src-data (f32array-data src)] 169 | [tgt-data (f32array-data tgt)]) 170 | (let loop ([i (f32array-iterator src)] 171 | [j (f32array-iterator tgt)]) 172 | (unless (nd-range-end? i) 173 | (f32vector-set! tgt-data (nd-range-offset j) 174 | (f32vector-ref src-data (nd-range-offset i))) 175 | (loop (nd-range-step i) (nd-range-step j)))))) 176 | 177 | (define-syntax f32a 178 | (lambda (x) 179 | (syntax-case x () 180 | ;;; 2d array syntax 181 | [(_ ( ...) ...) 182 | (with-syntax ([ (length #'(( ...) ...))] 183 | [ (length (car #'(( ...) ...)))]) 184 | #`(let* ([A (make-f32array '( ))] 185 | [d (f32array-data A)]) 186 | #,@(map (lambda (x n) 187 | #`(bv-sp-set! d #,(* 4 n) #,x)) 188 | (apply append #'(( ...) ...)) 189 | (iota (* #' #'))) 190 | A))] 191 | ;;; 1d array syntax 192 | [(_ ...) 193 | #`(let* ([v (make-f32array '(#,(length #'( ...))))] 194 | [d (f32array-data v)]) 195 | #,@(map (lambda (x n) 196 | #`(bv-sp-set! d #,(* 4 n) #,x)) 197 | #'( ...) 198 | (iota (length #'( ...)))) 199 | v)]))) 200 | ) 201 | 202 | -------------------------------------------------------------------------------- /lyonesse/munsch/linear-algebra.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse munsch linear-algebra) 2 | 3 | (export l:vector? make-l:vector l:vector-length l:vector-data 4 | l:vector-ref l:vector-set! l:v 5 | 6 | l:matrix? make-l:matrix l:matrix-m l:matrix-n l:matrix-data 7 | l:matrix-ref l:matrix-set! l:m l:eye 8 | 9 | l:dot l:* l:T l:vector->row-matrix l:vector->column-matrix 10 | l:map l:+ l:- 11 | 12 | l:matrix->f32array l:vector->f32array 13 | f32array->l:matrix f32array->l:vector 14 | 15 | l:print) 16 | 17 | (import (rnrs base (6)) 18 | (rnrs lists (6)) 19 | (rnrs control (6)) 20 | (rnrs io simple (6)) 21 | (rnrs syntax-case (6)) 22 | (rnrs bytevectors (6)) 23 | (rnrs records syntactic (6)) 24 | (srfi :48) 25 | 26 | (lyonesse functional) 27 | (lyonesse ranges) 28 | (lyonesse strings) 29 | (lyonesse record-with-context) 30 | (lyonesse munsch slice) 31 | (lyonesse munsch f32array)) 32 | 33 | #| Vector essentials ===================================================== |# 34 | (define-record-with-context l:vector 35 | (fields length data) 36 | (protocol 37 | (lambda (new) 38 | (case-lambda 39 | [(l) (new l (make-bytevector (* l 4)))] 40 | [(l data) (new l data)])))) 41 | 42 | (define (l:vector-ref v n) 43 | (f32vector-ref (l:vector-data v) n)) 44 | 45 | (define (l:vector-set! v n x) 46 | (f32vector-set! (l:vector-data v) n x)) 47 | 48 | #| Vector construction =================================================== |# 49 | (define-syntax l:v 50 | (lambda (x) 51 | (syntax-case x () 52 | [(_ ...) 53 | #`(let* ([v (make-l:vector #,(length #'( ...)))] 54 | [d (l:vector-data v)]) 55 | #,@(map (lambda (x n) 56 | #`(f32vector-set! d #,n #,x)) 57 | #'( ...) 58 | (iota (length #'( ...)))) 59 | v)]))) 60 | 61 | (define (l:vector->f32array v) 62 | (with-l:vector v (make-f32array (make-slice (list length)) data))) 63 | 64 | (define (f32array->l:vector a) 65 | (with-f32array a 66 | (unless (= 1 (slice-dimension slice)) 67 | (error 'f32array->l:vector "Array should be one-dimensional." a)) 68 | (with-slice slice 69 | (make-l:vector (car shape) 70 | (if (slice-contiguous? slice) 71 | data 72 | (f32array-copy-data a)))))) 73 | 74 | #| Vector operations ===================================================== |# 75 | (define (l:vector-scale a s) 76 | (let* ([l (l:vector-length a)] 77 | [b (make-l:vector l)]) 78 | (for-each (lambda (i) 79 | (l:vector-set! b i (* (l:vector-ref a i) s))) 80 | (iota l)) 81 | b)) 82 | 83 | (define (l:dot a b) 84 | (apply + (map (lambda (i) 85 | (* (l:vector-ref a i) (l:vector-ref b i))) 86 | (iota (l:vector-length a))))) 87 | 88 | #| Matrix essentials ===================================================== |# 89 | (define-record-with-context l:matrix 90 | (fields m n data) ; m rows, n columns 91 | (protocol 92 | (lambda (new) 93 | (case-lambda 94 | [(m n) (new m n (make-bytevector (* m n 4)))] 95 | [(m n data) (new m n data)])))) 96 | 97 | (define (l:matrix-ref A i j) 98 | (f32vector-ref (l:matrix-data A) (+ j (* i (l:matrix-n A))))) 99 | 100 | (define (l:matrix-set! A i j v) 101 | (f32vector-set! (l:matrix-data A) (+ j (* i (l:matrix-n A))) v)) 102 | 103 | (define (l:matrix->f32array A) 104 | (with-l:matrix A 105 | (make-f32array (make-slice (list m n)) data))) 106 | 107 | (define (f32array->l:matrix a) 108 | (with-f32array a 109 | (unless (= 2 (slice-dimension slice)) 110 | (error 'f32array->l:matrix "Array should be two-dimensional." a)) 111 | (with-slice slice 112 | (make-l:matrix (car shape) (cadr shape) 113 | (if (slice-contiguous? slice) 114 | data 115 | (f32array-copy-data a)))))) 116 | 117 | #| Matrix construction =================================================== |# 118 | (define-syntax l:m 119 | (lambda (x) 120 | (syntax-case x () 121 | [(_ ( ...) ...) 122 | (with-syntax ([ (length #'(( ...) ...))] 123 | [ (length (car #'(( ...) ...)))]) 124 | #`(let* ([A (make-l:matrix )] 125 | [d (l:matrix-data A)]) 126 | #,@(map (lambda (x n) 127 | #`(f32vector-set! d #,n #,x)) 128 | (apply append #'(( ...) ...)) 129 | (iota (* #' #'))) 130 | A))]))) 131 | 132 | (define (l:eye n) 133 | (let ([A (make-l:matrix n n)]) 134 | (for-range (lambda (i) 135 | (for-range (lambda (j) 136 | (l:matrix-set! A i j (if (= i j) 1 0))) 137 | n)) 138 | n) 139 | A)) 140 | 141 | #| Matrix operations ===================================================== |# 142 | (define (l:matrix-scale A s) 143 | (with-l:matrix A 144 | (make-l:matrix n m (f32vector-map ($ * s <>) data)))) 145 | 146 | (define (l:matrix-transpose A) 147 | (let* ([m (l:matrix-m A)] [n (l:matrix-n A)] 148 | [C (make-l:matrix n m)]) 149 | (for-range (lambda (i) 150 | (for-range (lambda (j) 151 | (l:matrix-set! C i j (l:matrix-ref A j i))) 152 | m)) 153 | n) 154 | C)) 155 | 156 | (define (l:matrix-mul A B) 157 | (let* ([m (l:matrix-m A)] [n (l:matrix-n A)] 158 | [p (l:matrix-m B)] [q (l:matrix-n B)] 159 | [C (make-l:matrix m q)]) 160 | (unless (= n p) 161 | (error 'l:matrix-mul "Matrix dimensions do not match." A B)) 162 | (for-range (lambda (i) 163 | (for-range (lambda (j) 164 | (l:matrix-set! C i j (apply + (map-range (lambda (k) 165 | (* (l:matrix-ref A i k) 166 | (l:matrix-ref B k j))) 167 | n)))) 168 | q)) 169 | m) 170 | C)) 171 | 172 | #| Matrix <-> Vector ===================================================== |# 173 | (define (l:vector->row-matrix v) 174 | (make-l:matrix 1 (l:vector-length v) (l:vector-data v))) 175 | 176 | (define (l:vector->column-matrix v) 177 | (make-l:matrix (l:vector-length v) 1 (l:vector-data v))) 178 | 179 | (define (l:matrix->vector A) 180 | (let ([m (l:matrix-m A)] [n (l:matrix-n A)]) 181 | (cond 182 | [(= 1 m) (make-l:vector n (l:matrix-data A))] 183 | [(= 1 n) (make-l:vector m (l:matrix-data A))] 184 | [else (error 'l:matrix->vector "Should be column or row matrix." A)]))) 185 | 186 | #| Generic routines ====================================================== |# 187 | (define (l:T a) 188 | (cond 189 | [(l:matrix? a) (l:matrix-transpose a)] 190 | [(l:vector? a) (l:vector->row-matrix a)])) 191 | 192 | (define (l:mul-2 a b) 193 | (cond 194 | [(and (number? a) (number? b)) (* a b)] 195 | [(and (number? a) (l:matrix? b)) (l:matrix-scale b a)] 196 | [(and (l:matrix? a) (number? b)) (l:matrix-scale a b)] 197 | [(and (l:matrix? a) (l:matrix? b)) (l:matrix-mul a b)] 198 | [(and (l:matrix? a) (l:vector? b)) (l:matrix->vector 199 | (l:matrix-mul a (l:vector->column-matrix b)))] 200 | [(and (l:vector? a) (l:matrix? b)) (l:matrix->vector 201 | (l:matrix-mul (l:vector->row-matrix a) b))] 202 | [(and (l:vector? a) (l:vector? b)) (l:dot a b)] 203 | [(and (number? a) (l:vector? b)) (l:vector-scale b a)] 204 | [(and (l:vector? a) (number? b)) (l:vector-scale a b)])) 205 | 206 | (define (l:* A . As) 207 | (fold-right l:mul-2 A As)) 208 | 209 | (define (l:map f x . xs) 210 | (cond 211 | [(l:matrix? x) 212 | (with-l:matrix x 213 | (make-l:matrix m n (apply f32vector-map f 214 | (map l:matrix-data (cons x xs)))))] 215 | [(l:vector? x) 216 | (with-l:vector x 217 | (make-l:vector length (apply f32vector-map f 218 | (map l:vector-data (cons x xs)))))])) 219 | 220 | (define (l:+ . args) (apply l:map + args)) 221 | (define (l:- . args) (apply l:map - args)) 222 | 223 | #| Output ================================================================ |# 224 | (define (l:matrix-format A) 225 | (f32array-format (l:matrix->f32array A))) 226 | 227 | (define (l:vector-format v) 228 | (f32array-format (l:vector->f32array v))) 229 | 230 | (define (l:print A) 231 | (cond 232 | [(l:matrix? A) (display (l:matrix-format A))] 233 | [(l:vector? A) (display (l:vector-format A))])) 234 | ) 235 | -------------------------------------------------------------------------------- /lyonesse/parsing/xml/parser.scm: -------------------------------------------------------------------------------- 1 | (library (lyonesse parsing xml parser) 2 | (export xml:ast-from-port) 3 | 4 | (import (rnrs base (6)) 5 | (rnrs lists (6)) 6 | (rnrs unicode (6)) 7 | (rnrs io ports (6)) 8 | 9 | (lyonesse functional) 10 | (lyonesse parsing ast-builder simple) 11 | (lyonesse parsing parser)) 12 | 13 | #| A parser takes a string and returns a parser and a string. 14 | |# 15 | (define (one-of . lst) 16 | ($ memq <> lst)) 17 | 18 | (define (char-identifier? ch) 19 | (or (char-alphabetic? ch) (char-numeric? ch) 20 | ((one-of #\- #\_) ch))) 21 | 22 | (define (parse:exit state input) 23 | (if (procedure? state) 24 | ((parse:error parse:exit "Unexpected end of file.") 25 | state input) 26 | state)) 27 | 28 | (define (parse:error proc msg) 29 | (lambda (state input) 30 | (if (procedure? state) 31 | (error parse:error msg (sb:close-all (state ')) input) 32 | (error parse:error msg state input)))) 33 | 34 | #| We're inside an XML context; until we recieve a closing tag, 35 | | the rest of this context should be valid (sub)XML. 36 | |# 37 | (define-parser (parse:content ch) 38 | [eof-object? parse:exit (sb:close)] 39 | [char-whitespace? parse:content ()] 40 | [($ char=? #\< <>) parse:tag ()] 41 | [($ char=? #\> <>) 42 | (parse:error parse:content "Unexpected character '>'") ()] 43 | [else parse:text (sb:new-string 44 | (sb:add ch))]) 45 | 46 | #| We've just opened a tag, we don't know if it is an opening 47 | | tag or a closing tag. 48 | |# 49 | (define-parser (parse:tag ch) 50 | [eof-object? (parse:error parse:tag "Unexpected EOF.") ()] 51 | [($ char=? #\/ <>) parse:closing-tag 52 | (sb:new-symbol (sb:add ch))] 53 | [($ char=? #\! <>) parse:!tag ()] 54 | [($ char=? #\? <>) parse:?tag ()] 55 | [char-identifier? parse:datum 56 | (sb:new-list sb:new-symbol (sb:add ch))] 57 | [else (parse:error parse:tag "XML syntax error.") ()]) 58 | 59 | 60 | (define-parser (parse:!tag ch) 61 | [eof-object? (parse:error parse:tag "Unexpected EOF.") ()] 62 | [($ char=? #\- <>) parse:maybe-comment ()] 63 | [char-identifier? parse:datum 64 | (sb:new-list sb:new-symbol (sb:add #\!) (sb:add ch))] 65 | [else (parse:error parse:!tag "XML syntax error.") ()]) 66 | 67 | (define-parser (parse:maybe-comment ch) 68 | [eof-object? (parse:error parse:maybe-comment "Unexpected EOF.") ()] 69 | [($ char=? #\- <>) parse:comment ()] 70 | [else (parse:error parse:maybe-comment "XML syntax error.") ()]) 71 | 72 | (define (parse:comment state input) 73 | (let loop ([expecting '(#\- #\- #\>)]) 74 | (cond 75 | [(null? expecting) 76 | (parse:content state input)] 77 | [(char=? (car expecting) (get-char input)) 78 | (loop (cdr expecting))] 79 | [else (loop '(#\- #\- #\>))]))) 80 | 81 | (define-parser (parse:?tag ch) 82 | [eof-object? (parse:error parse:tag "Unexpected EOF.") ()] 83 | [char-identifier? parse:?datum 84 | (sb:new-list (sb:add '?) sb:new-symbol (sb:add ch))] 85 | [else (parse:error parse:?tag "XML syntax error.") ()]) 86 | 87 | (define-parser (parse:?datum ch) 88 | [eof-object? (parse:error parse:tag "Unexpected EOF.") ()] 89 | [char-identifier? parse:?datum 90 | ((sb:add ch))] 91 | [char-whitespace? parse:attributes 92 | (sb:close sb:new-list (sb:add '~))] 93 | [($ char=? #\? <>) parse:close-datum 94 | (sb:close (sb:add '(~)) (sb:add '?) sb:close)] 95 | [else (parse:error parse:tag "XML syntax error.") ()]) 96 | 97 | #| It's an opening tag! We parse the name of the tag. If a whitespace 98 | | follows we parse attributes to this tag, if it closes with '/' we 99 | | know it is a single datum, if not we enter a new XML context. 100 | |# 101 | (define-parser (parse:datum ch) 102 | [eof-object? (parse:error parse:tag "Unexpected EOF.") ()] 103 | [char-identifier? parse:datum 104 | ((sb:add ch))] 105 | [char-whitespace? parse:attributes 106 | (sb:close sb:new-list (sb:add '~))] 107 | [($ char=? #\/ <>) parse:close-datum 108 | (sb:close (sb:add '(~)) sb:close)] 109 | [($ char=? #\> <>) parse:content 110 | (sb:close (sb:add '(~)))] 111 | [else (parse:error parse:tag "XML syntax error.") ()]) 112 | 113 | #| We've found a single datum tag, the only valid thing to follow is 114 | | the '>' character. 115 | |# 116 | (define-parser (parse:close-datum _) 117 | [eof-object? (parse:error parse:close-datum "Unexpected EOF.") ()] 118 | [($ char=? #\> <>) parse:content ()] 119 | [else (parse:error parse:close-datum "Expected '>'.") ()]) 120 | 121 | (define-parser (parse:attributes ch) 122 | [eof-object? (parse:error parse:attributes "Unexpected EOF.") ()] 123 | [char-whitespace? parse:attributes ()] 124 | [char-identifier? parse:attribute-pair 125 | (sb:new-list sb:new-symbol (sb:add ch))] 126 | [($ char=? #\/ <>) parse:close-datum 127 | (sb:close sb:close)] 128 | [($ char=? #\? <>) parse:close-datum 129 | (sb:close (sb:add '?) sb:close)] 130 | [($ char=? #\> <>) parse:content 131 | (sb:close)] 132 | [else (parse:error parse:attributes "XML syntax error.") ()]) 133 | 134 | (define-parser (parse:attribute-pair ch) 135 | [eof-object? (parse:error parse:attribute-pair "Unexpected EOF.") ()] 136 | [char-identifier? parse:attribute-pair 137 | ((sb:add ch))] 138 | [char-whitespace? parse:attribute-whitespace 139 | (sb:close)] 140 | [($ char=? #\= <>) parse:attribute-value 141 | (sb:close)] 142 | [($ char=? #\/ <>) parse:close-datum 143 | (sb:close (sb:add #t) sb:close sb:close)] 144 | [($ char=? #\> <>) parse:content 145 | (sb:close (sb:add #t) sb:close)] 146 | [else (parse:error parse:attribute-pair "XML syntax error.") ()]) 147 | 148 | (define-parser (parse:attribute-whitespace ch) 149 | [eof-object? (parse:error parse:attribute-whitespace "Unexpected EOF.") ()] 150 | [char-whitespace? parse:attribute-whitespace ()] 151 | [char-identifier? parse:attribute-pair 152 | ((sb:add #t) sb:close sb:new-list sb:new-symbol (sb:add ch))] 153 | [($ char=? #\= <>) parse:attribute-value ()] 154 | [($ char=? #\/ <>) parse:close-datum 155 | ((sb:add #t) sb:close sb:close sb:close)] 156 | [($ char=? #\> <>) parse:content 157 | ((sb:add #t) sb:close sb:close)] 158 | [else (parse:error parse:attribute-whitespace "XML syntax error.") ()]) 159 | 160 | (define-parser (parse:attribute-value ch) 161 | [eof-object? (parse:error parse:attribute-value "Unexpected EOF.") ()] 162 | [char-whitespace? parse:attribute-value ()] 163 | [($ char=? #\/ <>) parse:close-datum 164 | ((sb:add #t) sb:close sb:close sb:close)] 165 | [($ char=? #\> <>) parse:content 166 | ((sb:add #t) sb:close sb:close)] 167 | [($ char=? #\" <>) parse:string 168 | (sb:new-string)] 169 | [else (parse:error parse:attribute-value "XML syntax error.") ()]) 170 | 171 | (define-parser (parse:string ch) 172 | [eof-object? (parse:error parse:string "Unexpected EOF.") ()] 173 | [($ char=? #\" <>) parse:attributes 174 | (sb:close sb:close)] 175 | [($ char=? #\\ <>) parse:string-esc-char ()] 176 | [else parse:string 177 | ((sb:add ch))]) 178 | 179 | (define-parser (parse:string-esc-char ch) 180 | [eof-object? (parse:error parse:string-esc-char "Unexpected EOF.") ()] 181 | [($ char=? #\" <>) parse:string ((sb:add #\"))] 182 | [($ char=? #\n <>) parse:string ((sb:add #\newline))] 183 | [else (parse:error parse:string-esc-char 184 | "Unknown escape character in string.") ()]) 185 | 186 | (define-parser (parse:closing-tag ch) 187 | [eof-object? (parse:error parse:closing-tag "Unexpected EOF.") ()] 188 | [char-identifier? parse:closing-tag ((sb:add ch))] 189 | [($ char=? #\> <>) parse:content 190 | (sb:close sb:close)] 191 | [else (parse:error parse:closing-tag "XML syntax error.") ()]) 192 | 193 | (define-parser (parse:text ch) 194 | [eof-object? (parse:error parse:text "Unexpected EOF.") ()] 195 | [($ char=? #\& <>) parse:text-special-char 196 | (($ sb:new (compose xml:special-char list->string) <>))] 197 | [($ char=? #\< <>) parse:tag 198 | (sb:close)] 199 | [else parse:text 200 | ((sb:add ch))]) 201 | 202 | (define-parser (parse:text-special-char ch) 203 | [eof-object? (parse:error parse:text-special-char "Unexpected EOF.") ()] 204 | [($ char=? #\; <>) parse:text 205 | (sb:close)] 206 | [else parse:text-special-char 207 | ((sb:add ch))]) 208 | 209 | (define (xml:special-char name) 210 | (let* ([xml:chars '(("lt" . #\<) ("amp" . #\&) ("gt" . #\>) 211 | ("quot" . #\") ("apos" . #\'))] 212 | [ch (cdr (assoc name xml:chars))]) 213 | (if ch ch (error 'xml:special-char "Unknown XML special character." name)))) 214 | 215 | (define (xml:ast-from-port port) 216 | (parse:content (sb:start) port)) 217 | ) 218 | 219 | -------------------------------------------------------------------------------- /LICENSE-2.0.txt: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /lyonesse/streams/derived.scm: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) Philip L. Bewig (2007). All Rights Reserved. 2 | ;;; Permission is hereby granted, free of charge, to any person 3 | ;;; obtaining a copy of this software and associated documentation files 4 | ;;; (the "Software"), to deal in the Software without restriction, 5 | ;;; including without limitation the rights to use, copy, modify, merge, 6 | ;;; publish, distribute, sublicense, and/or sell copies of the Software, 7 | ;;; and to permit persons to whom the Software is furnished to do so, 8 | ;;; subject to the following conditions: 9 | ;;; 10 | ;;; The above copyright notice and this permission notice shall be 11 | ;;; included in all copies or substantial portions of the Software. 12 | ;;; 13 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 14 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 15 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 16 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 17 | ;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 18 | ;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 19 | ;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 20 | ;;; SOFTWARE. 21 | 22 | (library (lyonesse streams derived) 23 | 24 | (export stream-null stream-cons stream? stream-null? stream-pair? stream-car 25 | stream-cdr stream-lambda define-stream list->stream port->stream stream 26 | stream->list stream-append stream-concat stream-constant stream-drop 27 | stream-drop-while stream-filter stream-fold stream-for-each stream-from 28 | stream-iterate stream-length stream-let stream-map stream-match 29 | stream-of stream-range stream-ref stream-reverse stream-scan stream-take 30 | stream-take-while stream-unfold stream-unfolds stream-zip) 31 | 32 | (import (rnrs base (6)) 33 | (rnrs lists (6)) 34 | (rnrs syntax-case (6)) 35 | (rnrs io simple (6)) 36 | (lyonesse streams primitive)) 37 | 38 | (define-syntax define-stream 39 | (syntax-rules () 40 | ((define-stream (name . formal) body0 body1 ...) 41 | (define name (stream-lambda formal body0 body1 ...))))) 42 | 43 | (define (list->stream objs) 44 | (define list->stream 45 | (stream-lambda (objs) 46 | (if (null? objs) 47 | stream-null 48 | (stream-cons (car objs) (list->stream (cdr objs)))))) 49 | (if (not (list? objs)) 50 | (error 'list->stream "non-list argument") 51 | (list->stream objs))) 52 | 53 | (define (port->stream . port) 54 | (define port->stream 55 | (stream-lambda (p) 56 | (let ((c (read-char p))) 57 | (if (eof-object? c) 58 | stream-null 59 | (stream-cons c (port->stream p)))))) 60 | (let ((p (if (null? port) (current-input-port) (car port)))) 61 | (if (not (input-port? p)) 62 | (error 'port->stream "non-input-port argument") 63 | (port->stream p)))) 64 | 65 | (define-syntax stream 66 | (syntax-rules () 67 | ((stream) stream-null) 68 | ((stream x y ...) (stream-cons x (stream y ...))))) 69 | 70 | (define (stream->list . args) 71 | (let ((n (if (= 1 (length args)) #f (car args))) 72 | (strm (if (= 1 (length args)) (car args) (cadr args)))) 73 | (cond ((not (stream? strm)) (error 'stream->list "non-stream argument")) 74 | ((and n (not (integer? n))) (error 'stream->list "non-integer count")) 75 | ((and n (negative? n)) (error 'stream->list "negative count")) 76 | (else (let loop ((n (if n n -1)) (strm strm)) 77 | (if (or (zero? n) (stream-null? strm)) 78 | '() 79 | (cons (stream-car strm) (loop (- n 1) (stream-cdr strm))))))))) 80 | 81 | (define (stream-append . strms) 82 | (define stream-append 83 | (stream-lambda (strms) 84 | (cond ((null? (cdr strms)) (car strms)) 85 | ((stream-null? (car strms)) (stream-append (cdr strms))) 86 | (else (stream-cons (stream-car (car strms)) 87 | (stream-append (cons (stream-cdr (car strms)) (cdr strms)))))))) 88 | (cond ((null? strms) stream-null) 89 | ((exists (lambda (x) (not (stream? x))) strms) 90 | (error 'stream-append "non-stream argument")) 91 | (else (stream-append strms)))) 92 | 93 | (define (stream-concat strms) 94 | (define stream-concat 95 | (stream-lambda (strms) 96 | (cond ((stream-null? strms) stream-null) 97 | ((not (stream? (stream-car strms))) 98 | (error 'stream-concat "non-stream object in input stream")) 99 | ((stream-null? (stream-car strms)) 100 | (stream-concat (stream-cdr strms))) 101 | (else (stream-cons 102 | (stream-car (stream-car strms)) 103 | (stream-concat 104 | (stream-cons (stream-cdr (stream-car strms)) (stream-cdr strms)))))))) 105 | (if (not (stream? strms)) 106 | (error 'stream-concat "non-stream argument") 107 | (stream-concat strms))) 108 | 109 | (define stream-constant 110 | (stream-lambda objs 111 | (cond ((null? objs) stream-null) 112 | ((null? (cdr objs)) (stream-cons (car objs) (stream-constant (car objs)))) 113 | (else (stream-cons (car objs) 114 | (apply stream-constant (append (cdr objs) (list (car objs))))))))) 115 | 116 | (define (stream-drop n strm) 117 | (define stream-drop 118 | (stream-lambda (n strm) 119 | (if (or (zero? n) (stream-null? strm)) 120 | strm 121 | (stream-drop (- n 1) (stream-cdr strm))))) 122 | (cond ((not (integer? n)) (error 'stream-drop "non-integer argument")) 123 | ((negative? n) (error 'stream-drop "negative argument")) 124 | ((not (stream? strm)) (error 'stream-drop "non-stream argument")) 125 | (else (stream-drop n strm)))) 126 | 127 | (define (stream-drop-while pred? strm) 128 | (define stream-drop-while 129 | (stream-lambda (strm) 130 | (if (and (stream-pair? strm) (pred? (stream-car strm))) 131 | (stream-drop-while (stream-cdr strm)) 132 | strm))) 133 | (cond ((not (procedure? pred?)) (error 'stream-drop-while "non-procedural argument")) 134 | ((not (stream? strm)) (error 'stream-drop-while "non-stream argument")) 135 | (else (stream-drop-while strm)))) 136 | 137 | (define (stream-filter pred? strm) 138 | (define stream-filter 139 | (stream-lambda (strm) 140 | (cond ((stream-null? strm) stream-null) 141 | ((pred? (stream-car strm)) 142 | (stream-cons (stream-car strm) (stream-filter (stream-cdr strm)))) 143 | (else (stream-filter (stream-cdr strm)))))) 144 | (cond ((not (procedure? pred?)) (error 'stream-filter "non-procedural argument")) 145 | ((not (stream? strm)) (error 'stream-filter "non-stream argument")) 146 | (else (stream-filter strm)))) 147 | 148 | (define (stream-fold proc base strm) 149 | (cond ((not (procedure? proc)) (error 'stream-fold "non-procedural argument")) 150 | ((not (stream? strm)) (error 'stream-fold "non-stream argument")) 151 | (else (let loop ((base base) (strm strm)) 152 | (if (stream-null? strm) 153 | base 154 | (loop (proc base (stream-car strm)) (stream-cdr strm))))))) 155 | 156 | (define (stream-for-each proc . strms) 157 | (define (stream-for-each strms) 158 | (if (not (exists stream-null? strms)) 159 | (begin (apply proc (map stream-car strms)) 160 | (stream-for-each (map stream-cdr strms))))) 161 | (cond ((not (procedure? proc)) (error 'stream-for-each "non-procedural argument")) 162 | ((null? strms) (error 'stream-for-each "no stream arguments")) 163 | ((exists (lambda (x) (not (stream? x))) strms) 164 | (error 'stream-for-each "non-stream argument")) 165 | (else (stream-for-each strms)))) 166 | 167 | (define (stream-from first . step) 168 | (define stream-from 169 | (stream-lambda (first delta) 170 | (stream-cons first (stream-from (+ first delta) delta)))) 171 | (let ((delta (if (null? step) 1 (car step)))) 172 | (cond ((not (number? first)) (error 'stream-from "non-numeric starting number")) 173 | ((not (number? delta)) (error 'stream-from "non-numeric step size")) 174 | (else (stream-from first delta))))) 175 | 176 | (define (stream-iterate proc base) 177 | (define stream-iterate 178 | (stream-lambda (base) 179 | (stream-cons base (stream-iterate (proc base))))) 180 | (if (not (procedure? proc)) 181 | (error 'stream-iterate "non-procedural argument") 182 | (stream-iterate base))) 183 | 184 | (define (stream-length strm) 185 | (if (not (stream? strm)) 186 | (error 'stream-length "non-stream argument") 187 | (let loop ((len 0) (strm strm)) 188 | (if (stream-null? strm) 189 | len 190 | (loop (+ len 1) (stream-cdr strm)))))) 191 | 192 | (define-syntax stream-let 193 | (syntax-rules () 194 | ((stream-let tag ((name val) ...) body1 body2 ...) 195 | ((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...)))) 196 | 197 | (define (stream-map proc . strms) 198 | (define stream-map 199 | (stream-lambda (strms) 200 | (if (exists stream-null? strms) 201 | stream-null 202 | (stream-cons (apply proc (map stream-car strms)) 203 | (stream-map (map stream-cdr strms)))))) 204 | (cond ((not (procedure? proc)) (error 'stream-map "non-procedural argument")) 205 | ((null? strms) (error 'stream-map "no stream arguments")) 206 | ((exists (lambda (x) (not (stream? x))) strms) 207 | (error 'stream-map "non-stream argument")) 208 | (else (stream-map strms)))) 209 | 210 | (define-syntax stream-match 211 | (syntax-rules () 212 | ((stream-match strm-expr clause ...) 213 | (let ((strm strm-expr)) 214 | (cond 215 | ((not (stream? strm)) (error 'stream-match "non-stream argument")) 216 | ((stream-match-test strm clause) => car) ... 217 | (else (error 'stream-match "pattern failure"))))))) 218 | 219 | (define-syntax stream-match-test 220 | (syntax-rules () 221 | ((stream-match-test strm (pattern fender expr)) 222 | (stream-match-pattern strm pattern () (and fender (list expr)))) 223 | ((stream-match-test strm (pattern expr)) 224 | (stream-match-pattern strm pattern () (list expr))))) 225 | 226 | (define-syntax stream-match-pattern 227 | (lambda (x) 228 | (define (wildcard? x) 229 | (and (identifier? x) 230 | (free-identifier=? x (syntax _)))) 231 | (syntax-case x () 232 | ((stream-match-pattern strm () (binding ...) body) 233 | (syntax (and (stream-null? strm) (let (binding ...) body)))) 234 | ((stream-match-pattern strm (w? . rest) (binding ...) body) 235 | (wildcard? #'w?) 236 | (syntax (and (stream-pair? strm) 237 | (let ((strm (stream-cdr strm))) 238 | (stream-match-pattern strm rest (binding ...) body))))) 239 | ((stream-match-pattern strm (var . rest) (binding ...) body) 240 | (syntax (and (stream-pair? strm) 241 | (let ((temp (stream-car strm)) (strm (stream-cdr strm))) 242 | (stream-match-pattern strm rest ((var temp) binding ...) body))))) 243 | ((stream-match-pattern strm w? (binding ...) body) 244 | (wildcard? #'w?) 245 | (syntax (let (binding ...) body))) 246 | ((stream-match-pattern strm var (binding ...) body) 247 | (syntax (let ((var strm) binding ...) body)))))) 248 | 249 | (define-syntax stream-of 250 | (syntax-rules () 251 | ((_ expr rest ...) 252 | (stream-of-aux expr stream-null rest ...)))) 253 | 254 | (define-syntax stream-of-aux 255 | (syntax-rules (in is) 256 | ((stream-of-aux expr base) 257 | (stream-cons expr base)) 258 | ((stream-of-aux expr base (var in stream) rest ...) 259 | (stream-let loop ((strm stream)) 260 | (if (stream-null? strm) 261 | base 262 | (let ((var (stream-car strm))) 263 | (stream-of-aux expr (loop (stream-cdr strm)) rest ...))))) 264 | ((stream-of-aux expr base (var is exp) rest ...) 265 | (let ((var exp)) (stream-of-aux expr base rest ...))) 266 | ((stream-of-aux expr base pred? rest ...) 267 | (if pred? (stream-of-aux expr base rest ...) base)))) 268 | 269 | (define (stream-range first past . step) 270 | (define stream-range 271 | (stream-lambda (first past delta lt?) 272 | (if (lt? first past) 273 | (stream-cons first (stream-range (+ first delta) past delta lt?)) 274 | stream-null))) 275 | (cond ((not (number? first)) (error 'stream-range "non-numeric starting number")) 276 | ((not (number? past)) (error 'stream-range "non-numeric ending number")) 277 | (else (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1)))) 278 | (if (not (number? delta)) 279 | (error 'stream-range "non-numeric step size") 280 | (let ((lt? (if (< 0 delta) < >))) 281 | (stream-range first past delta lt?))))))) 282 | 283 | (define (stream-ref strm n) 284 | (cond ((not (stream? strm)) (error 'stream-ref "non-stream argument")) 285 | ((not (integer? n)) (error 'stream-ref "non-integer argument")) 286 | ((negative? n) (error 'stream-ref "negative argument")) 287 | (else (let loop ((strm strm) (n n)) 288 | (cond ((stream-null? strm) (error 'stream-ref "beyond end of stream")) 289 | ((zero? n) (stream-car strm)) 290 | (else (loop (stream-cdr strm) (- n 1)))))))) 291 | 292 | (define (stream-reverse strm) 293 | (define stream-reverse 294 | (stream-lambda (strm rev) 295 | (if (stream-null? strm) 296 | rev 297 | (stream-reverse (stream-cdr strm) (stream-cons (stream-car strm) rev))))) 298 | (if (not (stream? strm)) 299 | (error 'stream-reverse "non-stream argument") 300 | (stream-reverse strm stream-null))) 301 | 302 | (define (stream-scan proc base strm) 303 | (define stream-scan 304 | (stream-lambda (base strm) 305 | (if (stream-null? strm) 306 | (stream base) 307 | (stream-cons base (stream-scan (proc base (stream-car strm)) (stream-cdr strm)))))) 308 | (cond ((not (procedure? proc)) (error 'stream-scan "non-procedural argument")) 309 | ((not (stream? strm)) (error 'stream-scan "non-stream argument")) 310 | (else (stream-scan base strm)))) 311 | 312 | (define (stream-take n strm) 313 | (define stream-take 314 | (stream-lambda (n strm) 315 | (if (or (stream-null? strm) (zero? n)) 316 | stream-null 317 | (stream-cons (stream-car strm) (stream-take (- n 1) (stream-cdr strm)))))) 318 | (cond ((not (stream? strm)) (error 'stream-take "non-stream argument")) 319 | ((not (integer? n)) (error 'stream-take "non-integer argument")) 320 | ((negative? n) (error 'stream-take "negative argument")) 321 | (else (stream-take n strm)))) 322 | 323 | (define (stream-take-while pred? strm) 324 | (define stream-take-while 325 | (stream-lambda (strm) 326 | (cond ((stream-null? strm) stream-null) 327 | ((pred? (stream-car strm)) 328 | (stream-cons (stream-car strm) (stream-take-while (stream-cdr strm)))) 329 | (else stream-null)))) 330 | (cond ((not (stream? strm)) (error 'stream-take-while "non-stream argument")) 331 | ((not (procedure? pred?)) (error 'stream-take-while "non-procedural argument")) 332 | (else (stream-take-while strm)))) 333 | 334 | (define (stream-unfold mapper pred? generator base) 335 | (define stream-unfold 336 | (stream-lambda (base) 337 | (if (pred? base) 338 | (stream-cons (mapper base) (stream-unfold (generator base))) 339 | stream-null))) 340 | (cond ((not (procedure? mapper)) (error 'stream-unfold "non-procedural mapper")) 341 | ((not (procedure? pred?)) (error 'stream-unfold "non-procedural pred?")) 342 | ((not (procedure? generator)) (error 'stream-unfold "non-procedural generator")) 343 | (else (stream-unfold base)))) 344 | 345 | (define (stream-unfolds gen seed) 346 | (define (len-values gen seed) 347 | (call-with-values 348 | (lambda () (gen seed)) 349 | (lambda vs (- (length vs) 1)))) 350 | (define unfold-result-stream 351 | (stream-lambda (gen seed) 352 | (call-with-values 353 | (lambda () (gen seed)) 354 | (lambda (next . results) 355 | (stream-cons results (unfold-result-stream gen next)))))) 356 | (define result-stream->output-stream 357 | (stream-lambda (result-stream i) 358 | (let ((result (list-ref (stream-car result-stream) (- i 1)))) 359 | (cond ((pair? result) 360 | (stream-cons 361 | (car result) 362 | (result-stream->output-stream (stream-cdr result-stream) i))) 363 | ((not result) 364 | (result-stream->output-stream (stream-cdr result-stream) i)) 365 | ((null? result) stream-null) 366 | (else (error 'stream-unfolds "can't happen")))))) 367 | (define (result-stream->output-streams result-stream) 368 | (let loop ((i (len-values gen seed)) (outputs '())) 369 | (if (zero? i) 370 | (apply values outputs) 371 | (loop (- i 1) (cons (result-stream->output-stream result-stream i) outputs))))) 372 | (if (not (procedure? gen)) 373 | (error 'stream-unfolds "non-procedural argument") 374 | (result-stream->output-streams (unfold-result-stream gen seed)))) 375 | 376 | (define (stream-zip . strms) 377 | (define stream-zip 378 | (stream-lambda (strms) 379 | (if (exists stream-null? strms) 380 | stream-null 381 | (stream-cons (map stream-car strms) (stream-zip (map stream-cdr strms)))))) 382 | (cond ((null? strms) (error 'stream-zip "no stream arguments")) 383 | ((exists (lambda (x) (not (stream? x))) strms) 384 | (error 'stream-zip "non-stream argument")) 385 | (else (stream-zip strms))))) 386 | -------------------------------------------------------------------------------- /doc/Using Match.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Using Match 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 |

Using Match

13 |

R. Kent Dybvig

14 |

January 17, 2010

15 | 16 | 17 |

18 | 19 |

20 | 21 | 22 | 23 | 24 |
25 | 26 | 27 |

28 | This document describes a pattern matcher, unimaginatively called 29 | match, the source code for which is available at: 30 | 31 |

35 | A match expression looks a lot like a case expression, 36 | except that the keys are replaced with a pattern to be matched against 37 | the input. 38 | A match expression has the general form below. 39 | 40 |

41 | 42 |

(match input-expr clause) 43 |

Each clause consists of an input pattern, an optional guard, and a 44 | set of expressions. 45 | 46 |

47 | 48 |

[input-pattern expr1 expr2 ...] 49 |

or 50 | 51 |

52 | 53 |

[input-pattern (guard guard-expr ...) expr1 expr2 ...] 54 |

As with case, the input expression is evaluated to produce 55 | the input value, and the first clause the input value matches, 56 | if any, is selected. 57 | The output expressions of the selected clause are evaluated in sequence, 58 | and the value of the last expression is returned. 59 | 60 |

61 | An input value matches a clause if it fits the clause's pattern and 62 | passes the clause's guards, if any. 63 | Patterns may contain symbolic constants, which must match exactly, and 64 | pattern variables, which match any input. 65 | Pattern variables are prefixed by commas; symbolic constants are not. 66 | 67 |

68 | 69 |

(match '(a 17 37)
70 | 71 |   [(a ,x) 1]
72 | 73 |   [(b ,x ,y) 2]
74 | 75 |   [(a ,x ,y) 3]) <graphic> 3 76 |

The first clause fails to match because there are three items in the 77 | input list, and the pattern has only two. 78 | The second clause fails because b does not match a. 79 | 80 |

81 | In the output expression, the values of the pattern variables are 82 | bound to the corresponding pieces of input. 83 | 84 |

85 | 86 |

(match '(a 17 37)
87 | 88 |   [(a ,x) (- x)]
89 | 90 |   [(b ,x ,y) (+ x y)]
91 | 92 |   [(a ,x ,y) (* x y)]) <graphic> 629 93 |

When followed by an ellipsis (...), a pattern variable 94 | represents a sequence of input values. 95 | 96 |

97 | 98 |

(match '(a 17 37) [(a ,x* ...) x*]) <graphic> (17 37) 99 |

By convention, we place a * suffix on each pattern variable 100 | that matches a sequence of input expressions. 101 | This is just a convention, however, and not part of the syntax of 102 | match. 103 | 104 |

105 | Ellipses can follow a structured pattern containing one or more 106 | pattern variables. 107 | 108 |

109 | 110 |

(match '(say (a time) (stitch saves) (in nine))
111 | 112 |   [(say (,x* ,y*) ...) (append x* y*)]) <graphic> (a stitch in time saves nine) 113 |

Ellipses can be nested, producing sequences of sequences of values. 114 | 115 |

116 | 117 |

(match '((a b c d) (e f g) (h i) (j))
118 | 119 |   [((,x* ,y** ...) ...)
120 | 121 |    (list x* y**)]) <graphic> ((a e h j) ((b c d) (f g) (i) ())) 122 |

Recursion is frequently required while processing an input expression 123 | with match. 124 | Here is a simple definition of length using match. 125 | 126 |

127 | 128 |

(define length
129 | 130 |   (lambda (ls)
131 | 132 |     (match ls
133 | 134 |       [() 0]
135 | 136 |       [(,x . ,x*) (add1 (length x*))]))) 137 |

Using ellipses may make this more clear. 138 | 139 |

140 | 141 |

(define length
142 | 143 |   (lambda (ls)
144 | 145 |     (match ls
146 | 147 |       [() 0]
148 | 149 |       [(,x ,x* ...) (add1 (length x*))]))) 150 |

Here is a more realistic example of recursion. 151 | It also illustrates the use of guards and the use of 152 | error to signal match errors. 153 | 154 |

155 | 156 |

(define simple-eval
157 | 158 |   (lambda (x)
159 | 160 |     (match x
161 | 162 |       [,i (guard (integer? i)) i]
163 | 164 |       [(+ ,x* ...) (apply + (map simple-eval x*))]
165 | 166 |       [(* ,x* ...) (apply * (map simple-eval x*))]
167 | 168 |       [(- ,x ,y) (- (simple-eval x) (simple-eval y))]
169 | 170 |       [(/ ,x ,y) (/ (simple-eval x) (simple-eval y))]
171 | 172 |       [,x (error 'simple-eval "invalid expression ~s" x)]))) 173 |

Try out simple-eval using Chez Scheme's new-cafe 174 | with simple-eval as the evaluation procedure: 175 | 176 |

177 | 178 |

> (new-cafe simple-eval)
179 | 180 | >> (+ 1 2 3)       
181 | 182 | 6
183 | 184 | >> (+ (- 0 1) (+ 2 3))
185 | 186 | 4
187 | 188 | >> (- 1 2 3) 189 |
190 |
191 | Error in simple-eval: invalid expression (- 1 2 3).
192 | 193 | Type (debug) to enter the debugger.
194 | 195 | >>  196 |

Unlike case and cond, match does not have 197 | an explicit else clause. 198 | In fact, if a clause of the form 199 | 200 |

201 | 202 |

  [else expr] 203 |

is used, it matches (only) the symbol else. 204 | To achieve the effect of a catch-all clause, simple-eval 205 | uses the pattern ,x which matches any input. 206 | 207 |

208 | An even simpler version of the above uses match's 209 | "catamorphism" feature to perform the recursion 210 | automatically. 211 | 212 |

213 | 214 |

(define simple-eval
215 | 216 |   (lambda (x)
217 | 218 |     (match x
219 | 220 |       [,i (guard (integer? i)) i]
221 | 222 |       [(+ ,[x*] ...) (apply + x*)]
223 | 224 |       [(* ,[x*] ...) (apply * x*)]
225 | 226 |       [(- ,[x] ,[y]) (- x y)]
227 | 228 |       [(/ ,[x] ,[y]) (/ x y)]
229 | 230 |       [,x (error 'simple-eval "invalid expression ~s" x)]))) 231 |

In the second version of simple-eval, the explicit 232 | recursive calls are gone. 233 | Instead, the pattern variables have been written as 234 | ,[var]; this tells match to recur on the 235 | matching subpart of the input before evaluating the 236 | output expressions of the clause. 237 | Parentheses may be used in place of brackets, i.e., 238 | ,(var); we use brackets for readability. 239 | 240 |

241 | Here is another definition of length, this time using the 242 | catamorphism feature. 243 | 244 |

245 | 246 |

(define length
247 | 248 |   (lambda (x)
249 | 250 |     (match x
251 | 252 |       [() 0]
253 | 254 |       [(,x . ,[y]) (+ y 1)]))) 255 |

Since we usually use match to write translators from one 256 | language to another, we usually need to build an output expression, 257 | rather than return an output value. 258 | For example, the following converts let expressions into 259 | equivalent lambda applications. 260 | 261 |

262 | 263 |

(define translate
264 | 265 |   (lambda (x)
266 | 267 |     (match x
268 | 269 |       [(let ((,var* ,expr*) ...) ,body ,body* ...)
270 | 271 |        `((lambda ,var* ,body ,@body*) ,@expr*)]
272 | 273 |       [,x (error 'translate "invalid expression: ~s" x)]))) 274 |
275 |
276 | (translate '(let ((x 3) (y 4)) (+ x y))) <graphic> ((lambda (x y) (+ x y)) 3 4) 277 |

This procedure uses Scheme's quasiquote (backquote), 278 | unquote (comma), and unquote-splicing (comma-at) 279 | to piece together the output form. 280 | These are not described here, but are described in 281 | The 282 | Scheme Programming Language. 283 | 284 |

285 | One useful feature of quasiquote not described in these documents 286 | is a match extension that allows ellipses to be used in place 287 | of unquote-splicing, which often leads to more readable code. 288 | 289 |

290 | 291 |

(define translate
292 | 293 |   (lambda (x)
294 | 295 |     (match x
296 | 297 |       [(let ((,var* ,expr*) ...) ,body ,body* ...)
298 | 299 |        `((lambda ,var* ,body ,body* ...) ,expr* ...)]
300 | 301 |       [,x (error 'translate "invalid expression: ~s" x)]))) 302 |

Within each subform followed by an ellipsis, each 303 | comma-prefixed item must be a list and all such items within the same 304 | subform must have the same length. 305 | The following procedure extracts two lists from its input and merges 306 | them to form a list of pairs. 307 | 308 |

309 | 310 |

(define (f x)
311 | 312 |   (match x
313 | 314 |     [((,a ...) (,b ...)) `((,a . ,b) ...)]))
315 | 316 | (f '((1 2 3) (a b c))) <graphic> ((1 . a) (2 . b) (3 . c)) 317 |

It fails if the two lists have different lengths. 318 | 319 |

320 | 321 |

(f '((1 2 3) (a b))) <graphic> error 322 |

The following also fails because one of the items is not even a list. 323 | 324 |

325 | 326 |

(define (f x)
327 | 328 |   (match x
329 | 330 |     [(,a ,b ...) `((,a ,b) ...)]))
331 | 332 | (f '(1 2 3 4)) <graphic> error 333 |

A subform followed by an ellipses may be contained with a larger subform 334 | that is also followed by an ellipsis. 335 | In this case, each comma-prefixed item must be a list of lists, each such 336 | item must have the same length, and the corresponding sublists of each 337 | such item must have the same lengths. 338 | This requirement generalizes to comma-prefixed items nested within 339 | more than two levels of ellispis-followed subforms. 340 | 341 |

342 | The following procedure illustrates two levels of nested ellipses in both 343 | the input and output. 344 | It converts unnamed let expressions into 345 | direct lambda applications, where the let has been 346 | generalized to allow an implicit begin in each right-hand-side 347 | expression. 348 | 349 |

350 | 351 |

(define (f x)
352 | 353 |   (match x
354 | 355 |     [(let ([,x ,e1 ...] ...) ,b1 ,b2 ...)
356 | 357 |      `((lambda (,x ...) ,b1 ,b2 ...)
358 | 359 |        (begin ,e1 ...) ...)]))
360 | 361 | (f '(let ((x (write 'one) 3) (y (write 'two) 4)) (list x y))) <graphic>
362 | 363 |   ((lambda (x y) (list x y))
364 | 365 |    (begin (write 'one) 3)
366 | 367 |    (begin (write 'two) 4)) 368 |

In the output, a subform may be followed directly by two or more 369 | ellipses; the requirements are the same as for nested ellipses, but 370 | the result is flattened rather than nested, as illustrated by the 371 | following example. 372 | 373 |

374 | 375 |

(define (f x)
376 | 377 |   (match x
378 | 379 |     [(foo (,x ...) ...)
380 | 381 |      `(list (car ,x) ... ...)]))
382 | 383 | (f '(foo (a) (b c d e) () (f g))) <graphic>
384 | 385 |   (list (car a) (car b) (car c) (car d) (car e) (car f) (car g)) 386 |

Sometimes it is useful to explicitly name the operator in a 387 | "cata" subpattern. 388 | Whereas ,[id ...] recurs to the top of the current 389 | match, ,[cata -> id ...] recurs 390 | to cata. 391 | cata must evaluate to a procedure that accepts 392 | one argument, the input expression, and returns as many values 393 | as there are identifiers following the ->. 394 | 395 |

396 | This allows processing to be split into several 397 | mutually recursive procedures, as in the following parser for the simple 398 | language defined by the grammar below. 399 | 400 |

401 | 402 | 403 | 404 | 405 |

406 | <Prog><graphic>(program <Stmt>* <Expr>)
407 | <Stmt><graphic>(if <Expr> <Stmt> <Stmt>)
408 | |(set! <var> <Expr>)
409 | <Expr><graphic><var>
410 | |<integer>
411 | |(if <Expr> <Expr> <Expr>)
412 | |(<Expr> <Expr>*) 413 |
414 | 415 |

416 | 417 |

(define parse
418 | 419 |   (lambda (x)
420 | 421 |     (define Prog
422 | 423 |       (lambda (x)
424 | 425 |         (match x
426 | 427 |           [(program ,[Stmt -> s*] ... ,[Expr -> e])
428 | 429 |            `(begin ,s* ... ,e)]
430 | 431 |           [,x (error 'parse "invalid program ~s" x)])))
432 | 433 |     (define Stmt
434 | 435 |       (lambda (x)
436 | 437 |         (match x
438 | 439 |           [(if ,[Expr -> e] ,[Stmt -> s1] ,[Stmt -> s2])
440 | 441 |            `(if ,e ,s1 ,s2)]
442 | 443 |           [(set! ,v ,[Expr -> e])
444 | 445 |            (guard (symbol? v))
446 | 447 |            `(set! ,v ,e)]
448 | 449 |           [,x (error 'parse "invalid statement ~s" x)])))
450 | 451 |     (define Expr
452 | 453 |       (lambda (x)
454 | 455 |         (match x
456 | 457 |           [,v (guard (symbol? v)) v]
458 | 459 |           [,n (guard (integer? n)) n]
460 | 461 |           [(if ,[e1] ,[e2] ,[e3])
462 | 463 |            `(if ,e1 ,e2 ,e3)]
464 | 465 |           [(,[rator] ,[rand*] ...) `(,rator ,rand* ...)]
466 | 467 |           [,x (error 'parse "invalid expression ~s" x)])))
468 | 469 |     (Prog x))) 470 |
471 |
472 | (parse '(program (set! x 3) (+ x 4))) <graphic> (begin (set! x 3) (+ x 4)) 473 |

A mentioned above, the operator specified in the cata syntax can be any 474 | expression. 475 | We can make use of this to pass along an environment, if needed, say 476 | to handle a version of the language above extended with a 477 | let expression that creates bindings that might shadow keywords. 478 | 479 |

480 | 481 | 482 | 483 | 484 |

485 | <Prog><graphic>(program <Stmt>* <Expr>)
486 | <Stmt><graphic>(if <Expr> <Stmt> <Stmt>)
487 | |(set! <var> <Expr>)
488 | <Expr><graphic><var>
489 | |<integer>
490 | |(if <Expr> <Expr> <Expr>)
491 | |(let ((var <Expr>)) <Expr>)
492 | |(<Expr> <Expr>*) 493 |
494 | 495 |

496 | In the following version of parse, the output is more structured, 497 | with an explicit call keyword so that there will not be any 498 | confusion in the output between a call to the value of an if 499 | variable and a if expression keyed by the if keyword. 500 | 501 |

502 | 503 |

(define parse
504 | 505 |   (lambda (x)
506 | 507 |     (define Prog
508 | 509 |       (lambda (x)
510 | 511 |         (match x
512 | 513 |           [(program ,[Stmt -> s*] ... ,[(Expr '()) -> e])
514 | 515 |            `(begin ,s* ... ,e)]
516 | 517 |           [,x (error 'parse "invalid program ~s" x)])))
518 | 519 |     (define Stmt
520 | 521 |       (lambda (x)
522 | 523 |         (match x
524 | 525 |           [(if ,[(Expr '()) -> e] ,[Stmt -> s1] ,[Stmt -> s2])
526 | 527 |            `(if ,e ,s1 ,s2)]
528 | 529 |           [(set! ,v ,[(Expr '()) -> e])
530 | 531 |            (guard (symbol? v))
532 | 533 |            `(set! ,v ,e)]
534 | 535 |           [,x (error 'parse "invalid statement ~s" x)])))
536 | 537 |     (define Expr
538 | 539 |       (lambda (env)
540 | 541 |         (lambda (x)
542 | 543 |           (match x
544 | 545 |             [,v (guard (symbol? v)) v]
546 | 547 |             [,n (guard (integer? n)) n]
548 | 549 |             [(if ,[e1] ,[e2] ,[e3])
550 | 551 |              (guard (not (memq 'if env)))
552 | 553 |              `(if ,e1 ,e2 ,e3)]
554 | 555 |             [(let ([,v ,[e]]) ,[(Expr (cons v env)) -> body])
556 | 557 |              (guard (not (memq 'let env)) (symbol? v))
558 | 559 |              `(let ([,v ,e]) ,body)]
560 | 561 |             [(,[rator] ,[rand*] ...)
562 | 563 |              `(call ,rator ,rand* ...)]
564 | 565 |             [,x (error 'parse "invalid expression ~s" x)]))))
566 | 567 |     (Prog x))) 568 |
569 |
570 | (parse
571 | 572 |   '(program                          (begin
573 | 574 |      (let ([if (if x list values)]) <graphic>   (let ([if (if x list values)])
575 | 576 |        (if 1 2 3))))                     (call if 1 2 3))) 577 |

When recurring via a cata call without an explicit operator, e.g., 578 | within the Expr if and application cases, the value of 579 | Expr's env argument does not change, which is good, 580 | since nothing needs to be added to the environment at those call sites. 581 | The value of Expr's x argument does not 582 | change either, so the clause that reads 583 | 584 |

585 | 586 |

            [,v (guard (symbol? v)) v] 587 |

should not be replaced by one that reads 588 | 589 |

590 | 591 |

            [,v (guard (symbol? v)) x] 592 |

or nested expressions will not be handled properly. 593 | In general, the values of any variables bound outside a match 594 | expression do not change when a cata call is used to recur 595 | directly to the match itself. 596 | 597 |

598 | In some cases, a procedure that uses match will need to return 599 | multiple values. 600 | Programs return multiple values using the values 601 | procedure and receive them using the let-values 602 | syntactic form. 603 | These features are described in 604 | The 605 | Scheme Programming Language. 606 | Here is a simple example adapted from The Scheme Programming Language. 607 | 608 |

609 | 610 |

(define split
611 | 612 |   (lambda (ls)
613 | 614 |     (if (or (null? ls) (null? (cdr ls)))
615 | 616 |         (values ls '())
617 | 618 |         (let-values ([(odds evens) (split (cddr ls))])
619 | 620 |           (values (cons (car ls) odds)
621 | 622 |                   (cons (cadr ls) evens)))))) 623 |
624 |
625 | (split '(a b c d e f)) <graphic> (a c e)
626 | 627 |                         (b d f) 628 |

The values procedure is used to return multiple values; it 629 | takes an arbitrary number of arguments and returns them as the values. 630 | If passed one value, values behaves like the identity. 631 | let-values is like let, except that each binding binds 632 | zero or more variables to zero or more return values. 633 | 634 |

635 | The pattern matcher cata syntax can also be used to receive multiple 636 | values. 637 | When making implicit recursive calls using the cata (,[]) syntax, 638 | one can include zero or more variables between the brackets 639 | (after the ->, if one is present), 640 | each representing one of the expected return values. 641 | split may thus be defined using match as follows. 642 | 643 |

644 | 645 |

(define split
646 | 647 |   (lambda (ls)
648 | 649 |     (match ls
650 | 651 |       [() (values '() '())]
652 | 653 |       [(,x) (values `(,x) '())]
654 | 655 |       [(,x ,y . ,[odds evens])
656 | 657 |        (values (cons x odds)
658 | 659 |                (cons y evens))]))) 660 |
661 |
662 | (split '(a b c d e f)) <graphic> (a c e)
663 | 664 |                         (b d f) 665 |

666 | 667 | 668 |

© 2013 R. Kent Dybvig 669 |

670 | 671 |

--------------------------------------------------------------------------------

32 | http://www.cs.indiana.edu/chezscheme/match/match.ss 33 | 34 |