source: project/release/5/holes/trunk/holes.scm

Last change on this file was 37987, checked in by juergen, 4 months ago

holes 1.2 with new delimiters and without read macros

File size: 7.8 KB
Line 
1; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
2;
3; Copyright (c) 2016-2018, Juergen Lorenz
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without
7; modification, are permitted provided that the following conditions are
8; met:
9;
10; Redistributions of source code must retain the above copyright
11; notice, this list of conditions and the following dispasser.
12;
13; Redistributions in binary form must reproduce the above copyright
14; notice, this list of conditions and the following dispasser in the
15; documentation and/or other materials provided with the distribution.
16;
17; Neither the name of the author nor the names of its contributors may be
18; used to endorse or promote products derived from this software without
19; specific prior written permission.
20;
21; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
22; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
23; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
24; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32
33
34#|[
35Besides the documentation procedure, this module exports two curry
36procedures, @> and @<, and a macro, @@, which implements the holes
37mechanism. All three return procedures.
38
39Holes are symbols delimited by < and >, possibly enclosing zero or more
40digits.  The macro @@ transforms expressions with zero or more holes
41into a procedure. Insofar, it's a bit like cut or cute. But while in cut
42or cute the same symbol <> can denote different arguments, in @@ <>, <1>
43and <2>, say, are all different (and ordered) arguments.
44]|#
45
46(module holes (holes @@ @> @<)
47  (import scheme
48          (only (chicken base) error case-lambda print)
49          (only (chicken syntax) define-for-syntax))
50  (import-for-syntax (only (chicken base) receive)
51                     (only (chicken fixnum) fx- fx+ fx=))
52
53;;; (@@ code)
54;;; ---------
55;;; returns a procedure with arguments the holes in code
56(define-syntax @@
57  (er-macro-transformer
58    (lambda (form rename compare?)
59      (let (
60        (code (cadr form))
61        (%lambda (rename 'lambda))
62        (flatten*
63          ; imported flatten doesn't work with pseudo-lists
64          (lambda (tree)
65            (let loop ((tree tree) (result '()))
66              (cond
67                ((pair? tree)
68                 (loop (car tree) (loop (cdr tree) result)))
69                ((null? tree) result)
70                (else
71                  (cons tree result))))))
72        (hole?
73          (lambda (sym)
74            (and (symbol? sym)
75                 (let* ((lst (string->list (symbol->string sym)))
76                        (len (length lst))
77                        (target (string->list "0123456789")))
78                   (and (char=? (car lst) #\<)
79                                ;(string-ref delimiters 0))
80                        (char=? (list-ref lst (fx- len 1)) #\>);)
81                                ;(string-ref delimiters 1))
82                        (let loop ((k 1) (result #t))
83                          (call/cc
84                            (lambda (out)
85                              (if (fx= k (fx- len 1))
86                                result
87                                (loop (fx+ k 1)
88                                      (if (memq (list-ref lst k)
89                                                target)
90                                        result
91                                        (out #f))))))))))))
92        (filter
93          (lambda (ok? lst)
94            (compress (map ok? lst) lst)))
95        (ninsert
96          (lambda (n lon)
97            (let loop ((lon lon))
98              (cond
99                ((null? lon) (list n))
100                ((= n (car lon)) lon)
101                ((< n (car lon)) (cons n lon))
102                ((> n (car lon))
103                 (cons (car lon) (loop (cdr lon))))))))
104        (split-with
105          (lambda (where? lst)
106            (let loop ((tail lst) (head '()))
107              (if (or (null? tail) (where? (car tail)))
108                (values (reverse head) tail)
109                (loop (cdr tail) (cons (car tail) head))))))
110        (no-dups?
111          (lambda (lst)
112            (let loop ((lst lst) (result '()))
113              (cond
114                ((null? lst) #t)
115                ((memq (car lst) result) #f)
116                (else (loop (cdr lst)
117                            (cons (car lst) result)))))))
118        )
119        (let* (
120          (nsort
121            (lambda (lon)
122              (let loop ((lon lon) (result '()))
123                (if (null? lon)
124                  result
125                  (loop (cdr lon) (ninsert (car lon) result))))))
126          (hsort
127            (lambda (holes)
128              (let* (
129                (strings (map symbol->string holes))
130                (substrings
131                  (map (lambda (s)
132                         (substring s 1 (fx- (string-length s) 1)))
133                       strings))
134                (nums (map string->number
135                           (filter (lambda (s)
136                                     (not (string=? s "")))
137                                   substrings)))
138                (snums (nsort nums))
139                (sstrings
140                  (map (lambda (s)
141                         (string-append "<";(substring delimiters 0 1) ;;;
142                                        s
143                                        ">"));(substring delimiters 1)))
144                       (map number->string snums)))
145                (sholes (map string->symbol sstrings))
146                )
147                (if (memq (string->symbol "<>") holes);delimiters) holes)
148                  (cons (string->symbol "<>") sholes) ;delimiters) sholes)
149                  sholes))))
150          )
151          `(,%lambda
152             ,(hsort (filter hole? (flatten* code)))
153             ,code))))))
154
155;;; (@> proc . head)
156;;; ----------------
157;;; returns a curried procedure with arguments tail, which applies proc to
158;;; (append head tail)
159(define (@> proc . head)
160  (lambda tail
161    (apply proc (append head tail))))
162
163
164;;; (@< proc . tail)
165;;; ----------------
166;;; returns a curried procedure with arguments head, which applies proc to
167;;; (append head tail)
168(define (@< proc . tail)
169  (lambda head
170    (apply proc (append head tail))))
171
172;;; (holes [sym])
173;;; -------------
174;;; documentation procderue
175(define holes
176  (let ((als '(
177    (holes
178      procedure:
179      (holes sym ..)
180      "documentation procedure")
181    (@@
182      macro:
183      (@@ code)
184      "extracts holes, i.e. a symbol delimited by < and >"
185      "possible enclosing a seqence of digits"
186      "from code, sorts them numerically while"
187      "removing duplicates, and uses"
188      "the resulting list as argument list of"
189      "a procedure with body code."
190      "Note, that (@@ code) is always a procedure!"
191      ""
192      "The (@@ code) notation can be further simplyfied"
193      "to, e.g, ^code with a read macro in the client code")
194    (@>
195      procedure:
196      (@> proc . head)
197      "returns a curried procedure with arguments tail"
198      "which applies proc to (append head tail)")
199    (@<
200      procedure:
201      (@< proc . tail)
202      "returns a curried procedure with arguments head"
203      "which applies proc to (append head tail)")
204    )))
205    (case-lambda
206      (()
207       (map car als))
208      ((sym)
209       (let ((pair (assq sym als)))
210         (if pair
211           (for-each print (cdr pair))
212           (error "Not in list"
213                  sym
214                  (map car als))))))))
215
216) ; module holes
217
Note: See TracBrowser for help on using the repository browser.