home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / schmlbrr / schem_lb.lha / unsupported / CScheme / bsort.scm < prev    next >
Encoding:
Text File  |  1991-08-05  |  2.0 KB  |  72 lines
  1. ;;; -*- Base: 10; Mode: Scheme; Syntax: MIT Scheme; Package: USER -*-
  2. ;;
  3. ;; BSORT.SCM
  4. ;;
  5. ;; July 25, 1991
  6. ;; Minghsun Liu
  7. ;;
  8. ;; Implement CL-SORT using bubble sort.
  9. ;;
  10.  
  11. ;;
  12. ;; Same as the CL-SORT in sequence.scm but uses the bubble sort function
  13. ;; below instead of the built-in ones in MIT Scheme. (Q-SORT??)
  14. ;;
  15. (define (cl-sort seq pred #!rest keyword)
  16.   (let ((keyfnc '()))
  17.     (define (process-keyword)
  18.       (if (not (null? keyword))
  19.           (if (eq? (car keyword) :key)
  20.               (set! keyfnc (cadr keyword))
  21.               (error "CL-SORT: unknown keyword" keyword))))
  22.     (define (get-predicate)
  23.       (if keyfnc
  24.           (lambda (x y)
  25.             (let ((a (keyfnc x))
  26.                   (b (keyfnc y)))
  27.               (or (pred a b)
  28.                   (equal? a b))))
  29.           (lambda (x y)
  30.             (or (pred a b) (equal? a b)))))
  31.     (process-keyword)
  32.     (cond ((array? seq)
  33.            (list->vector
  34.         (bsort (vector->list (just-the-array-maam seq)) (get-predicate))))
  35.           ((string? seq)
  36.            (set! seq (string->list seq))
  37.            (list->string (bsort seq (get-predicate))))
  38.           ((vector? seq)
  39.            (list->vector (bsort (vector->list seq) (get-predicate))))
  40.           ((list? seq)
  41.            (bsort seq (get-predicate)))
  42.           (else (error "CL-SORT: Not a sequence" seq)))))
  43.  
  44. ;;
  45. ;; (BSORT LIST)
  46. ;;
  47. ;; sorts a list using bubble sort.
  48. ;;
  49. (define (bsort list-to-sort pred)
  50.   (let ((max (-1+ (length list-to-sort)))
  51.     (index 0)
  52.     (temp '()))
  53.     (define (bsort-aux cur-list)
  54.       (cond ((= max 0) 
  55.          list-to-sort)
  56.         ((= index max)
  57.          (set! index 0)
  58.          (set! max (-1+ max))
  59.          (bsort-aux list-to-sort))
  60.         ((not (pred (car cur-list) (cadr cur-list)))
  61.          (set! temp (car cur-list))
  62.          (set-car! cur-list (cadr cur-list))
  63.          (set-car! (cdr cur-list) temp)
  64.          (set! index (1+ index))
  65.          (bsort-aux (cdr cur-list)))
  66.         (else
  67.          (set! index (1+ index))
  68.          (bsort-aux (cdr cur-list)))))
  69.     (if (null? list-to-sort)
  70.     '()
  71.     (bsort-aux list-to-sort))))
  72.