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

Last change on this file since 37980 was 37980, checked in by juergen, 5 months ago

version 1.1 with parameter hole-delimiters

File size: 8.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
36procedure, @> and @<, one macro, @@, and a sharp-read-macro, ##, which
37abbreviates the call of that latter macro.
38
39The macro transforms expressions with zero or more holes into a
40procedure. Insofar, it's a bit like cut or cute. But while in cut or
41cute a hole is the special identifier <>, in this module it's a pair of
42bangs, possibly enclosing a sequence of digits, for examples !! or !1!.
43In this way, holes needn't name different variables like in cut or cute.
44
45Another difference to cut or cute is, that the holes may appear in
46nested expressions at different levels. This gives great flexibility.
47And the sharp-read-syntax ## adds ease of use.
48]|#
49
50(module holes (holes @@ @> @<)
51  (import scheme
52          (only (chicken base) error case-lambda print make-parameter)
53          (only (chicken syntax) define-for-syntax)
54          (only (chicken read-syntax)
55                set-sharp-read-syntax!
56                set-read-syntax!))
57  (import-for-syntax (only (chicken base) receive)
58                     (only (chicken fixnum) fx- fx+ fx=))
59
60(define-for-syntax hole-delimiters
61  (make-parameter "<>"
62                  (lambda (arg)
63                    (if (and (string? arg)
64                             (or (string=? arg "!!")
65                                 (string=? arg "<>")))
66                        arg
67                        "<>"))
68                  ))
69;;; (@@ code)
70;;; ---------
71;;; returns a procedure with arguments the holes in code
72(define-syntax @@
73  (er-macro-transformer
74    (lambda (form rename compare?)
75      (let (
76        (code (cadr form))
77        (%lambda (rename 'lambda))
78        (flatten*
79          ; imported flatten doesn't work with pseudo-lists
80          (lambda (tree)
81            (let loop ((tree tree) (result '()))
82              (cond
83                ((pair? tree)
84                 (loop (car tree) (loop (cdr tree) result)))
85                ((null? tree) result)
86                (else
87                  (cons tree result))))))
88        (hole?
89          (lambda (sym)
90            (and (symbol? sym)
91                 (let* ((lst (string->list (symbol->string sym)))
92                        (len (length lst))
93                        (target (string->list "0123456789")))
94                   (and (char=? (car lst)
95                                (string-ref (hole-delimiters) 0))
96                        (char=? (list-ref lst (fx- len 1))
97                                (string-ref (hole-delimiters) 1))
98                        (let loop ((k 1) (result #t))
99                          (call/cc
100                            (lambda (out)
101                              (if (fx= k (fx- len 1))
102                                result
103                                (loop (fx+ k 1)
104                                      (if (memq (list-ref lst k)
105                                                target)
106                                        result
107                                        (out #f))))))))))))
108        (filter
109          (lambda (ok? lst)
110            (compress (map ok? lst) lst)))
111        (ninsert
112          (lambda (n lon)
113            (let loop ((lon lon))
114              (cond
115                ((null? lon) (list n))
116                ((= n (car lon)) lon)
117                ((< n (car lon)) (cons n lon))
118                ((> n (car lon))
119                 (cons (car lon) (loop (cdr lon))))))))
120        (split-with
121          (lambda (where? lst)
122            (let loop ((tail lst) (head '()))
123              (if (or (null? tail) (where? (car tail)))
124                (values (reverse head) tail)
125                (loop (cdr tail) (cons (car tail) head))))))
126        (no-dups?
127          (lambda (lst)
128            (let loop ((lst lst) (result '()))
129              (cond
130                ((null? lst) #t)
131                ((memq (car lst) result) #f)
132                (else (loop (cdr lst)
133                            (cons (car lst) result)))))))
134        )
135        (let* (
136          (nsort
137            (lambda (lon)
138              (let loop ((lon lon) (result '()))
139                (if (null? lon)
140                  result
141                  (loop (cdr lon) (ninsert (car lon) result))))))
142          (hsort
143            (lambda (holes)
144              (let* (
145                (strings (map symbol->string holes))
146                (substrings
147                  (map (lambda (s)
148                         (substring s 1 (fx- (string-length s) 1)))
149                       strings))
150                (nums (map string->number
151                           (filter (lambda (s)
152                                     (not (string=? s "")))
153                                   substrings)))
154                (snums (nsort nums))
155                (sstrings
156                  (map (lambda (s)
157                         (string-append (substring (hole-delimiters) 0 1)
158                                        s
159                                        (substring (hole-delimiters) 1)))
160                       (map number->string snums)))
161                (sholes (map string->symbol sstrings))
162                )
163                (if (memq (string->symbol (hole-delimiters)) holes)
164                  (cons (string->symbol (hole-delimiters)) sholes)
165                  sholes))))
166          )
167          `(,%lambda
168             ,(hsort (filter hole? (flatten* code)))
169             ,code))))))
170
171(set-sharp-read-syntax! #\#
172  (lambda (port) `(@@ ,(read port))))
173(set-read-syntax! #\^
174  (lambda (port) `(@@ ,(read port))))
175
176;;; (@> proc . head)
177;;; ----------------
178;;; returns a curried procedure with arguments tail, which applies proc to
179;;; (append head tail)
180(define (@> proc . head)
181  (lambda tail
182    (apply proc (append head tail))))
183
184
185;;; (@< proc . tail)
186;;; ----------------
187;;; returns a curried procedure with arguments head, which applies proc to
188;;; (append head tail)
189(define (@< proc . tail)
190  (lambda head
191    (apply proc (append head tail))))
192
193;;; (holes [sym])
194;;; -------------
195;;; documentation procderue
196(define holes
197  (let ((als '(
198    (holes
199      procedure:
200      (holes sym ..)
201      "documentation procedure")
202    (hole-delimiters
203      parameter:
204      (hole-delimiters str ..)
205      "returns or sets the delimiters"
206      "accepted strings are \"<>\" and \"!!\""
207      "\"<>\" is the default")
208    (@@
209      macro:
210      (@@ code)
211      "extracts holes, i.e. a pair of bangs"
212      "or the pair <> depending on the parameter"
213      "hole-delimiters"
214      "possible enclosing a seqence of digits"
215      "from code, sorts them numerically while"
216      "removing duplicates, and uses"
217      "the resulting list as argument list of"
218      "a procedure with body code."
219      ""
220      "Can be called with sharp-read-syntax ##"
221      "or read-syntax ^"
222      "Note, that (@@ code), and hence ##code,"
223      "or ^code is always a procedure!")
224    (@>
225      procedure:
226      (@> proc . head)
227      "returns a curried procedure with arguments tail"
228      "which applies proc to (append head tail)")
229    (@<
230      procedure:
231      (@< proc . tail)
232      "returns a curried procedure with arguments head"
233      "which applies proc to (append head tail)")
234    )))
235    (case-lambda
236      (()
237       (map car als))
238      ((sym)
239       (let ((pair (assq sym als)))
240         (if pair
241           (for-each print (cdr pair))
242           (error "Not in list"
243                  sym
244                  (map car als))))))))
245
246) ; module holes
247
Note: See TracBrowser for help on using the repository browser.