Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 97 lines (81 sloc) 2.625 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96
(define (delq item list)
  "Return list with all items eq? to item removed."
  (filter (complement (curry eq? item)) list))

(define (delv item list)
  "Return list with all items eqv? to item removed."
  (filter (complement (curry eqv? item)) list))

(define (delete item list)
  "Return list with all items equal? to item removed."
  (filter (complement (curry equal? item)) list))

(define (remove-if test lst)
  "Remove elements matching predicate."
  (filter (complement test) lst))

(define (plist-get list key (fail #f))
  "Return property value in plist."
  (if (null? list)
      fail
      (if (eq? key (first list))
(second list)
(plist-get (cddr list) key :fail fail))))

(define (plist-set! list key value)
  "Set property value in plist."
  (if (null? list)
      #f
      (if (eq? key (first list))
(begin
(set-cdr! list (cons value (cddr list)))
value)
(plist-set! (cddr list) key value))))

(define (nthcdr n lst)
  "Return nth cdr of list."
  (if (zero? n)
      lst
      (nthcdr (- n 1) (cdr lst))))

(define (make-list len init)
  "Make a new list of length LEN composed of INIT."
  (if (zero? len)
      '()
      (cons init (make-list (- len 1) init))))

(define (copy-list lst)
  "Make a copy of the list, sharing elements."
  (if (null? lst)
      '()
      (cons (car lst) (copy-list (cdr lst)))))

(letrec ((merge (lambda (test key a b)
(cond
((null? a) b)
((null? b) a)
((test (key (car b)) (key (car a)))
(cons (car b) (merge test key a (cdr b))))
(#t (cons (car a) (merge test key (cdr a) b)))))))

  (define (mergesort! lst test key)
    "Destructively mergesort the given list, ascending by test."
    (let ((len (length lst)))
      (if (<= len 1)
lst
(let* ((left-end (nthcdr (- (/ len 2) 1) lst))
(right (cdr left-end)))
(set-cdr! left-end '())
(merge test key
(mergesort! lst test key)
(mergesort! right test key)))))))

(define (sort! lst test (key identity))
  "Destructively sort a list, by test."
  (mergesort! lst test key))

(define (sort lst test (key identity))
  "Non-destructively sort a list, by test."
  (mergesort! (copy-list lst) test key))

(define stable-sort sort)

;; Define a better map using the old one
(let ((oldmap map))
  (define (multi-list-map fn lists)
    "map FN across the elements of LISTS where fn should have an arity
equal to the number of lists"
    (if (any? null? lists)
()
(cons (apply fn (oldmap car lists))
(multi-list-map fn (oldmap cdr lists)))))

  (define (map fn lst . lists)
    (if lists
(multi-list-map fn (cons lst lists))
(oldmap fn lst))))
Something went wrong with that request. Please try again.