From: "andrew cooke" <andrew@...>
Date: Tue, 14 Aug 2007 22:53:01 -0400 (CLT)
":";exec snow -- "$0" "$@"
(package* permute/v1.0.0
(provide: (define (permute lst))))
; generates a list of all permutations
; assumes all values in original list are unique (under equal?)
(define (permute lst)
(case (length lst)
((0) '())
((1) (list lst))
(else (flat-map (lambda (head)
(map (lambda (perm) (cons head perm))
(permute (except head lst))))
lst))))
(define (flat-map f lst) (flat-map-acc f lst '()))
(define (flat-map-acc f lst acc)
(if (null? lst)
acc
(flat-map-acc f (cdr lst) (append acc (f (car lst))))))
; this does not attempt to keep any kind of ordering
(define (except x lst) (except-acc x lst '()))
(define (except-acc x lst acc)
(if (null? lst)
acc
(let ((head (car lst))
(tail (cdr lst)))
(if (equal? x head)
(append acc tail)
(except-acc x tail (cons head acc))))))
(test*
(define (dup x) (list x x))
(expect* (equal? '() (flat-map dup '())))
(expect* (equal? '(1 1) (flat-map dup '(1))))
(expect* (equal? '(1 1 2 2) (flat-map dup '(1 2)))))
(test*
(expect* (equal? '() (except 0 '())))
(expect* (equal? '() (except 1 '(1))))
(expect* (equal? '(2) (except 1 '(1 2))))
(expect* (equal? '(3 2 1) (except 0 '(1 2 3))))
(expect* (equal? '(2 3) (except 1 '(1 2 3))))
(expect* (equal? '(1 3) (except 2 '(1 2 3))))
(expect* (equal? '(2 1) (except 3 '(1 2 3)))))
(test*
(expect* (equal? '() (permute '())))
(expect* (equal? '((1)) (permute '(1))))
(expect* (equal? '((1 2)(2 1)) (permute '(1 2))))
(expect* (equal? '((1 2 3)(1 3 2)(2 1 3)(2 3 1)(3 2 1)(3 1 2))
(permute '(1 2 3)))))
Improved Permutation Function (Start of List Library)
From: "andrew cooke" <andrew@...>
Date: Wed, 15 Aug 2007 12:07:38 -0400 (CLT)
":";exec snow -- "$0" "$@"
; library of list-related functions
(package* ac-lists/v1.0.0
(provide:
; abstract the typical patter used to recurse over lists
(define-syntax acl-list-process
(syntax-rules (null?)
((_ ((null? list) null-body)
((head tail) body))
(if (null? list)
null-body
(let ((head (car list))
(tail (cdr list)))
body)))))
(define (acl-filter pred lst))
(define (acl-filter-acc pred lst acc))
(define (acl-except x lst))
(define (acl-flat-map fun lst))
(define (acl-flat-map-acc fun lst acc))
(define (acl-permute lst))
))
; remove all values that match predicate from a list
(define (acl-filter pred lst) (reverse (acl-filter-acc pred lst '())))
(define (acl-filter-acc pred lst acc)
(acl-list-process
((null? lst) acc)
((head tail) (if (pred head)
(acl-filter-acc pred tail acc)
(acl-filter-acc pred tail (cons head acc))))))
(test*
(define (one? x) (= 1 x))
(expect* (equal? '() (acl-filter one? '())))
(expect* (equal? '() (acl-filter one? '(1))))
(expect* (equal? '(2) (acl-filter one? '(2))))
(expect* (equal? '(2 3) (acl-filter one? '(2 1 3)))))
; exclude instances of a particular value
(define (acl-except x lst) (acl-filter (lambda (y) (equal? x y)) lst))
(test*
(expect* (equal? '() (acl-except 0 '())))
(expect* (equal? '() (acl-except 1 '(1))))
(expect* (equal? '(2) (acl-except 1 '(1 2))))
(expect* (equal? '(1 2 3) (acl-except 0 '(1 2 3)))))
; map with append instead of cons
(define (acl-flat-map fun lst) (reverse (acl-flat-map-acc fun lst '())))
(define (acl-flat-map-acc fun lst acc)
(acl-list-process
((null? lst) acc)
((head tail) (acl-flat-map-acc fun tail (append (fun head) acc)))))
(test*
(define (dup x) (list x x))
(expect* (equal? '() (acl-flat-map dup '())))
(expect* (equal? '(1 1) (acl-flat-map dup '(1))))
(expect* (equal? '(1 1 2 2) (acl-flat-map dup '(1 2)))))
; a list of all permutations
; assumes all values in original list are unique (under equal?)
(define (acl-permute lst)
(define (perm-rest x)
(define (cons-x rest) (cons x rest))
(let ((rest (acl-except x lst)))
(map cons-x (acl-permute rest))))
(acl-list-process
((null? lst) '())
((head tail) (if (null? tail)
(list lst)
(acl-flat-map perm-rest lst)))))
(test*
(expect* (equal? '() (acl-permute '())))
(expect* (equal? '((1)) (acl-permute '(1))))
(expect* (equal? '((1 2)(2 1)) (acl-permute '(1 2))))
(expect* (equal? '((1 3 2)(1 2 3)(2 3 1)(2 1 3)(3 2 1)(3 1 2))
(acl-permute '(1 2 3)))))