; mid-term exam (define (task1 str1 str2) (do ((cs (string->list str2) (cdr cs)) (idx 0 (+ idx 1)) (pos (list) (cons (cons (car cs) idx) pos))) ((null? cs) (let loop ((cs (string->list str1))) (cond ((null? cs) #f) ((assoc (car cs) pos) => cdr) (else (loop (cdr cs)))))))) (display (task1 "ayc4xbz" "012345")) (newline) (display (task1 "ayc7xbz" "012345")) (newline) (define-syntax fold-of (syntax-rules (range in is) ((_ "z" f b e) (set! b (f b e))) ((_ "z" f b e (v range fst pst stp) c ...) (let* ((x fst) (p pst) (s stp) (le? (if (positive? s) <= >=))) (do ((v x (+ v s))) ((le? p v) b) (fold-of "z" f b e c ...)))) ((_ "z" f b e (v range fst pst) c ...) (let* ((x fst) (p pst) (s (if (< x p) 1 -1))) (fold-of "z" f b e (v range x p s) c ...))) ((_ "z" f b e (v range pst) c ...) (fold-of "z" f b e (v range 0 pst) c ...)) ((_ "z" f b e (x in xs) c ...) (do ((t xs (cdr t))) ((null? t) b) (let ((x (car t))) (fold-of "z" f b e c ...)))) ((_ "z" f b e (x is y) c ...) (let ((x y)) (fold-of "z" f b e c ...))) ((_ "z" f b e p? c ...) (if p? (fold-of "z" f b e c ...))) ((_ f i e c ...) (let ((b i)) (fold-of "z" f b e c ...))))) (define-syntax list-of (syntax-rules () ((_ arg ...) (reverse (fold-of (lambda (d a) (cons a d)) '() arg ...))))) (define (group-by eql? xs) (let loop ((xs xs) (ys '()) (zs '())) (cond ((null? xs) (reverse (if (null? ys) zs (cons (reverse ys) zs)))) ((null? (cdr xs)) (reverse (cons (reverse (cons (car xs) ys)) zs))) ((eql? (car xs) (cadr xs)) (loop (cdr xs) (cons (car xs) ys) zs)) (else (loop (cddr xs) (list (cadr xs)) (cons (reverse (cons (car xs) ys)) zs)))))) (define (task2 xs) (map (lambda (xs) (list (cadar xs) (map car xs))) (group-by (lambda (a b) (= (cadr a) (cadr b))) (sort (list-of (list (car r) i) (r in xs) (i in (cdr r))) (lambda (a b) (< (cadr a) (cadr b))))))) (define recipes '((a 1 2 3) (b 2 4 6) (c 3 6 7) (d 4 5) (e 5 7 9) (f 6 7 8) (g 8 9))) (display (task2 recipes)) (newline)