153 lines
4.2 KiB
Scheme
153 lines
4.2 KiB
Scheme
;;
|
|
;; template-list-expander.scm
|
|
;;
|
|
;; Dynamic length lists based on simple templates with head and tail
|
|
;; patterns.
|
|
;;
|
|
;; ISC License
|
|
;;
|
|
;; Copyright 2023 Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
;;
|
|
;; Permission to use, copy, modify, and/or distribute this software
|
|
;; for any purpose with or without fee is hereby granted, provided
|
|
;; that the above copyright notice and this permission notice appear
|
|
;; in all copies.
|
|
;;
|
|
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
|
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
|
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
|
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
|
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
|
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
|
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
|
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
;;
|
|
|
|
(declare (unit template-list-expander))
|
|
|
|
(module
|
|
template-list-expander
|
|
(
|
|
template-expansion-token?
|
|
|
|
expand-template-list
|
|
|
|
template-list-expander-tests!
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
testing)
|
|
|
|
(define (template-expansion-token? token)
|
|
(and (symbol? token)
|
|
(let* ((tokenstr (symbol->string token))
|
|
(tokenlen (string-length tokenstr)))
|
|
(and (>= tokenlen 3)
|
|
(string=? (substring tokenstr 0 3) "...")))))
|
|
|
|
(define (split-template-list temp-lst)
|
|
(let loop ((lst temp-lst)
|
|
(rhead '()))
|
|
(if (null? lst)
|
|
(values temp-lst '() '())
|
|
(let* ((token (car lst))
|
|
(tokenstr (if (symbol? token)
|
|
(symbol->string token)
|
|
""))
|
|
(tokenlen (if (symbol? token)
|
|
(string-length tokenstr)
|
|
0)))
|
|
(cond ((and (symbol? token)
|
|
(>= tokenlen 3)
|
|
(string=? (substring tokenstr 0 3) "..."))
|
|
(let rloop ((cnt (- tokenlen 2))
|
|
(rhead2 rhead)
|
|
(rrep '()))
|
|
(if (= cnt 0)
|
|
(values (reverse rhead2)
|
|
rrep
|
|
(cdr lst))
|
|
(rloop (sub1 cnt)
|
|
(cdr rhead2)
|
|
(cons (car rhead2) rrep)))))
|
|
(else
|
|
(loop (cdr lst)
|
|
(cons token rhead))))))))
|
|
|
|
(define (repeat-list-for lst len)
|
|
(let loop ((cnt len)
|
|
(rep lst)
|
|
(res '()))
|
|
(if (= cnt 0)
|
|
(reverse res)
|
|
(loop (sub1 cnt)
|
|
(if (null? (cdr rep)) lst (cdr rep))
|
|
(cons (car rep) res)))))
|
|
|
|
(define (take-from-list lst cnt)
|
|
(let loop ((lst lst)
|
|
(res '())
|
|
(cnt cnt))
|
|
(if (= cnt 0)
|
|
(reverse res)
|
|
(loop (cdr lst)
|
|
(cons (car lst) res)
|
|
(sub1 cnt)))))
|
|
|
|
(define (expand-template-list lst len)
|
|
(let-values (((head rep tail) (split-template-list lst)))
|
|
(let ((headlen (length head))
|
|
(taillen (length tail)))
|
|
;;(print "----------------")
|
|
;;(print "head = " head)
|
|
;;(print "rep = " rep)
|
|
;;(print "tail = " tail)
|
|
(cond
|
|
((= len headlen)
|
|
head)
|
|
((< len headlen)
|
|
(take-from-list head len))
|
|
(else
|
|
(let ((head+taillen (+ headlen taillen)))
|
|
(cond
|
|
((= len head+taillen)
|
|
(append head tail))
|
|
((< len head+taillen)
|
|
(append head (take-from-list tail (- len head+taillen))))
|
|
(else
|
|
(append head
|
|
(repeat-list-for rep (- len head+taillen))
|
|
tail)))))))))
|
|
|
|
(define (template-list-expander-tests!)
|
|
(run-tests
|
|
template-list-expander
|
|
(test-equal? expand-template-list
|
|
(expand-template-list '() 0)
|
|
'())
|
|
(test-equal? expand-template-list
|
|
(expand-template-list '((a) ... (b)) 5)
|
|
'((a) (a) (a) (a) (b)))
|
|
(test-equal? expand-template-list
|
|
(expand-template-list '((c) (a) (d) ... (b) (e)) 9)
|
|
'((c) (a) (d) (d) (d) (d) (d) (b) (e)))
|
|
(test-equal? expand-template-list
|
|
(expand-template-list '((c) (a) (d) .... (b) (e)) 9)
|
|
'((c) (a) (d) (a) (d) (a) (d) (b) (e)))
|
|
(test-true template-expansion-token?
|
|
(template-expansion-token? '...))
|
|
(test-true template-expansion-token?
|
|
(template-expansion-token? '....))
|
|
(test-false template-expansion-token?
|
|
(template-expansion-token? '..))
|
|
(test-false template-expansion-token?
|
|
(template-expansion-token? 'hello))
|
|
(test-false template-expansion-token?
|
|
(template-expansion-token? "hello"))
|
|
(test-equal? expand-template-list
|
|
(expand-template-list '(a b ... c) 2)
|
|
'(a c))
|
|
))
|
|
|
|
)
|