utilities.scm

   1 ;;;; File: "utilities.scm", Time-stamp: <2006-05-08 16:04:37 feeley>
   2
   3 ;;;; Copyright (C) 2004-2009 by Marc Feeley and Vincent St-Amour
   4 ;;;; All Rights Reserved.
   5
   6 (define keep
   7   (lambda (keep? lst)
   8     (cond ((null? lst)       '())
   9           ((keep? (car lst)) (cons (car lst) (keep keep? (cdr lst))))
  10           (else              (keep keep? (cdr lst))))))
  11
  12 (define take
  13   (lambda (n lst)
  14     (if (> n 0)
  15         (cons (car lst) (take (- n 1) (cdr lst)))
  16         '())))
  17
  18 (define drop
  19   (lambda (n lst)
  20     (if (> n 0)
  21         (drop (- n 1) (cdr lst))
  22         lst)))
  23
  24 (define repeat
  25   (lambda (n x)
  26     (if (> n 0)
  27         (cons x (repeat (- n 1) x))
  28         '())))
  29
  30 (define pos-in-list
  31   (lambda (x lst)
  32     (let loop ((lst lst) (i 0))
  33       (cond ((not (pair? lst)) #f)
  34             ((eq? (car lst) x) i)
  35             (else              (loop (cdr lst) (+ i 1)))))))
  36
  37 (define every
  38   (lambda (pred? lst)
  39     (or (null? lst)
  40         (and (pred? (car lst))
  41              (every pred? (cdr lst))))))
  42
  43
  44 (define (sort-list l <?)
  45
  46   (define (mergesort l)
  47
  48     (define (merge l1 l2)
  49       (cond ((null? l1) l2)
  50             ((null? l2) l1)
  51             (else
  52              (let ((e1 (car l1)) (e2 (car l2)))
  53                (if (<? e1 e2)
  54                  (cons e1 (merge (cdr l1) l2))
  55                  (cons e2 (merge l1 (cdr l2))))))))
  56
  57     (define (split l)
  58       (if (or (null? l) (null? (cdr l)))
  59         l
  60         (cons (car l) (split (cddr l)))))
  61
  62     (if (or (null? l) (null? (cdr l)))
  63       l
  64       (let* ((l1 (mergesort (split l)))
  65              (l2 (mergesort (split (cdr l)))))
  66         (merge l1 l2))))
  67
  68   (mergesort l))