Changeset 5800 in project


Ignore:
Timestamp:
08/29/07 01:37:44 (13 years ago)
Author:
wmfarr
Message:

Reverted unsafe changes in trunk.

Location:
pairing-heap
Files:
1 added
3 edited
1 copied

Legend:

Unmodified
Added
Removed
  • pairing-heap/branches/unsafe/trunk/pairing-heap.scm

    r5784 r5800  
    3737 (lambda-lift)
    3838 (usual-integrations)
     39 (unsafe)
    3940 (export pairing-heap?
    4041         pairing-heap-empty
     
    4849
    4950(use srfi-1)
     51
     52(define-macro (my-assert ppred? oobj procedure message . objs)
     53  (let ((pred? (gensym 'pred?))
     54        (obj (gensym 'obj)))
     55    `(let ((,pred? ,ppred?)
     56           (,obj ,oobj))
     57       (when (not (,pred? ,obj))
     58         (error ,procedure ,message ,@objs)))))
    5059
    5160;; Each pairing heap stores a suspension (i.e. (delay ...)) of its own
     
    6473(define pairing-heap? %ph?)
    6574
    66 (define (pairing-heap-empty compare)
     75(define (%pairing-heap-empty compare)
    6776  (make-%ph compare *empty-elt* (delay (error 'pairing-heap-remove-min
    6877                                              "cannot remove min from empty heap"))))
    6978
     79(define (pairing-heap-empty compare)
     80  (my-assert procedure?
     81             compare
     82             'pairing-heap-empty
     83             "expected procedure for comparison, got "
     84             compare)
     85  (%pairing-heap-empty compare))
     86
     87(define (%pairing-heap-empty? h)
     88  (eq? (%ph-elt h) *empty-elt*))
     89
    7090(define (pairing-heap-empty? h)
    71   (eq? *empty-elt* (%ph-elt h)))
     91  (my-assert pairing-heap? h 'pairing-heap-empty? "expected pairing-heap, got " h)
     92  (%pairing-heap-empty? h))
     93
     94(define (%pairing-heap-min h)
     95  (%ph-elt-min (%ph-elt h)))
    7296
    7397(define (pairing-heap-min h)
    74   (%ph-elt-min (%ph-elt h)))
     98  (my-assert (lambda (obj) (not (pairing-heap-empty? obj)))
     99             h
     100             'pairing-heap-min
     101             "cannot take min element of empty pairing heap "
     102             h)
     103  (%pairing-heap-min h))
    75104
    76105(define (<? compare obj1 obj2)
     
    81110
    82111(define (pairing-heap-merge h1 h2)
     112  (my-assert pairing-heap?
     113             h1
     114             'pairing-heap-merge
     115             "expected pairing-heap for first argument, got "
     116             h1)
     117  (my-assert pairing-heap?
     118             h2
     119             'pairing-heap-merge
     120             "expected pairing-heap for second argument, got "
     121             h2)
     122  (%pairing-heap-merge h1 h2))
     123
     124(define (%pairing-heap-merge h1 h2)
    83125  (cond
    84126   ((pairing-heap-empty? h2) h1)
     
    86128   (else
    87129    (let ((compare (%ph-compare h1))
    88           (m1 (pairing-heap-min h1))
    89           (m2 (pairing-heap-min h2)))
     130          (m1 (%pairing-heap-min h1))
     131          (m2 (%pairing-heap-min h2)))
    90132      (if (<? compare m1 m2)
    91133          (let ((h (make-%ph compare
     
    101143
    102144(define (pairing-heap-insert elt ph)
     145  (my-assert pairing-heap?
     146             ph
     147             'pairing-heap-insert
     148             "expected pairing heap for second argument, got "
     149             ph)
     150  (%pairing-heap-insert elt ph))
     151
     152(define (%pairing-heap-insert elt ph)
    103153  (let ((compare (%ph-compare ph)))
    104     (pairing-heap-merge
     154    (%pairing-heap-merge
    105155     (make-%ph compare
    106156               (make-%ph-elt elt '())
    107                (delay (pairing-heap-empty compare)))
     157               (delay (%pairing-heap-empty compare)))
    108158     ph)))
    109159
     
    122172             (pair-loop
    123173              (cddr hs)
    124               (cons (pairing-heap-merge (car hs) (cadr hs))
     174              (cons (%pairing-heap-merge (car hs) (cadr hs))
    125175                    merged-hs)))))))
    126     (fold pairing-heap-merge (pairing-heap-empty (%ph-compare h)) merged-pairs)))
     176    (fold %pairing-heap-merge (%pairing-heap-empty (%ph-compare h)) merged-pairs)))
    127177
    128178;; Just force (%remove-min h).
    129179(define (pairing-heap-remove-min h)
     180  (my-assert pairing-heap?
     181             h
     182             'pairing-heap-remove-min
     183             "expected pairing-heap, got "
     184             h)
    130185  (force (%ph-remove-min-heap h)))
    131186
    132187(define (pairing-heap-fold kons knil h)
    133   (if (pairing-heap-empty? h)
     188  (my-assert procedure?
     189             kons
     190             'pairing-heap-fold
     191             "expected procedure for first argument, got "
     192             kons)
     193  (my-assert pairing-heap?
     194             h
     195             'pairing-heap-fold
     196             "expected pairing-heap for third argument, got "
     197             h)
     198  (%pairing-heap-fold kons knil h))
     199
     200(define (%pairing-heap-fold kons knil h)
     201  (if (%pairing-heap-empty? h)
    134202      knil
    135203      (fold (lambda (sub-heap acc)
    136               (pairing-heap-fold kons acc sub-heap))
     204              (%pairing-heap-fold kons acc sub-heap))
    137205            (kons (%ph-elt-min (%ph-elt h)) knil)
    138206            (sub-heaps h))))
    139207
    140208(define (pairing-heap-sort compare list-or-vector)
     209  (my-assert procedure?
     210             compare
     211             'pairing-heap-sort
     212             "expected comparison procedure for first argument, got "
     213             compare)
     214  (my-assert (lambda (obj) (or (vector? obj) (list? obj)))
     215             list-or-vector
     216             'pairing-heap-sort
     217             "expected list or vector for second argument, got "
     218             list-or-vector)
    141219  (if (list? list-or-vector)
    142220      (sort-list compare list-or-vector)
     
    145223(define (sort-list compare list)
    146224  (let ((rev-compare (lambda (obj1 obj2) (fx* -1 (compare obj1 obj2)))))
    147     (let ((h (fold pairing-heap-insert (pairing-heap-empty rev-compare) list)))
     225    (let ((h (fold %pairing-heap-insert (%pairing-heap-empty rev-compare) list)))
    148226      (let loop ((sorted-elts '())
    149227                 (h h))
    150         (if (pairing-heap-empty? h)
     228        (if (%pairing-heap-empty? h)
    151229            sorted-elts
    152             (loop (cons (pairing-heap-min h) sorted-elts)
     230            (loop (cons (%pairing-heap-min h) sorted-elts)
    153231                  (pairing-heap-remove-min h)))))))
    154232
    155233(define (sort-vector compare vec)
    156234  (let* ((n (vector-length vec))
    157          (h (let h-loop ((h (pairing-heap-empty compare))
     235         (h (let h-loop ((h (%pairing-heap-empty compare))
    158236                         (i 0))
    159237              (if (fx>= i n)
    160238                  h
    161                   (h-loop (pairing-heap-insert (vector-ref vec i) h)
     239                  (h-loop (%pairing-heap-insert (vector-ref vec i) h)
    162240                          (fx+ i 1))))))
    163241    (let ((result (make-vector n)))
     
    167245            result
    168246            (begin
    169               (vector-set! result i (pairing-heap-min h))
     247              (vector-set! result i (%pairing-heap-min h))
    170248              (result-loop (fx+ i 1) (pairing-heap-remove-min h))))))))
    171249
  • pairing-heap/branches/unsafe/trunk/pairing-heap.setup

    r5784 r5800  
    1 (compile -s -O2 -d1 pairing-heap.scm)
     1(compile -s -O2 -d0 pairing-heap.scm)
    22(install-extension
    33 'pairing-heap
  • pairing-heap/trunk/pairing-heap.scm

    r5799 r5800  
    3737 (lambda-lift)
    3838 (usual-integrations)
    39  (unsafe)
    4039 (export pairing-heap?
    4140         pairing-heap-empty
     
    4948
    5049(use srfi-1)
    51 
    52 (define-macro (my-assert ppred? oobj procedure message . objs)
    53   (let ((pred? (gensym 'pred?))
    54         (obj (gensym 'obj)))
    55     `(let ((,pred? ,ppred?)
    56            (,obj ,oobj))
    57        (when (not (,pred? ,obj))
    58          (error ,procedure ,message ,@objs)))))
    5950
    6051;; Each pairing heap stores a suspension (i.e. (delay ...)) of its own
     
    7364(define pairing-heap? %ph?)
    7465
    75 (define (%pairing-heap-empty compare)
     66(define (pairing-heap-empty compare)
    7667  (make-%ph compare *empty-elt* (delay (error 'pairing-heap-remove-min
    7768                                              "cannot remove min from empty heap"))))
    7869
    79 (define (pairing-heap-empty compare)
    80   (my-assert procedure?
    81              compare
    82              'pairing-heap-empty
    83              "expected procedure for comparison, got "
    84              compare)
    85   (%pairing-heap-empty compare))
    86 
    87 (define (%pairing-heap-empty? h)
    88   (eq? (%ph-elt h) *empty-elt*))
    89 
    9070(define (pairing-heap-empty? h)
    91   (my-assert pairing-heap? h 'pairing-heap-empty? "expected pairing-heap, got " h)
    92   (%pairing-heap-empty? h))
    93 
    94 (define (%pairing-heap-min h)
     71  (eq? *empty-elt* (%ph-elt h)))
     72
     73(define (pairing-heap-min h)
    9574  (%ph-elt-min (%ph-elt h)))
    96 
    97 (define (pairing-heap-min h)
    98   (my-assert (lambda (obj) (not (pairing-heap-empty? obj)))
    99              h
    100              'pairing-heap-min
    101              "cannot take min element of empty pairing heap "
    102              h)
    103   (%pairing-heap-min h))
    10475
    10576(define (<? compare obj1 obj2)
     
    11081
    11182(define (pairing-heap-merge h1 h2)
    112   (my-assert pairing-heap?
    113              h1
    114              'pairing-heap-merge
    115              "expected pairing-heap for first argument, got "
    116              h1)
    117   (my-assert pairing-heap?
    118              h2
    119              'pairing-heap-merge
    120              "expected pairing-heap for second argument, got "
    121              h2)
    122   (%pairing-heap-merge h1 h2))
    123 
    124 (define (%pairing-heap-merge h1 h2)
    12583  (cond
    12684   ((pairing-heap-empty? h2) h1)
     
    12886   (else
    12987    (let ((compare (%ph-compare h1))
    130           (m1 (%pairing-heap-min h1))
    131           (m2 (%pairing-heap-min h2)))
     88          (m1 (pairing-heap-min h1))
     89          (m2 (pairing-heap-min h2)))
    13290      (if (<? compare m1 m2)
    13391          (let ((h (make-%ph compare
     
    143101
    144102(define (pairing-heap-insert elt ph)
    145   (my-assert pairing-heap?
    146              ph
    147              'pairing-heap-insert
    148              "expected pairing heap for second argument, got "
    149              ph)
    150   (%pairing-heap-insert elt ph))
    151 
    152 (define (%pairing-heap-insert elt ph)
    153103  (let ((compare (%ph-compare ph)))
    154     (%pairing-heap-merge
     104    (pairing-heap-merge
    155105     (make-%ph compare
    156106               (make-%ph-elt elt '())
    157                (delay (%pairing-heap-empty compare)))
     107               (delay (pairing-heap-empty compare)))
    158108     ph)))
    159109
     
    172122             (pair-loop
    173123              (cddr hs)
    174               (cons (%pairing-heap-merge (car hs) (cadr hs))
     124              (cons (pairing-heap-merge (car hs) (cadr hs))
    175125                    merged-hs)))))))
    176     (fold %pairing-heap-merge (%pairing-heap-empty (%ph-compare h)) merged-pairs)))
     126    (fold pairing-heap-merge (pairing-heap-empty (%ph-compare h)) merged-pairs)))
    177127
    178128;; Just force (%remove-min h).
    179129(define (pairing-heap-remove-min h)
    180   (my-assert pairing-heap?
    181              h
    182              'pairing-heap-remove-min
    183              "expected pairing-heap, got "
    184              h)
    185130  (force (%ph-remove-min-heap h)))
    186131
    187132(define (pairing-heap-fold kons knil h)
    188   (my-assert procedure?
    189              kons
    190              'pairing-heap-fold
    191              "expected procedure for first argument, got "
    192              kons)
    193   (my-assert pairing-heap?
    194              h
    195              'pairing-heap-fold
    196              "expected pairing-heap for third argument, got "
    197              h)
    198   (%pairing-heap-fold kons knil h))
    199 
    200 (define (%pairing-heap-fold kons knil h)
    201   (if (%pairing-heap-empty? h)
     133  (if (pairing-heap-empty? h)
    202134      knil
    203135      (fold (lambda (sub-heap acc)
    204               (%pairing-heap-fold kons acc sub-heap))
     136              (pairing-heap-fold kons acc sub-heap))
    205137            (kons (%ph-elt-min (%ph-elt h)) knil)
    206138            (sub-heaps h))))
    207139
    208140(define (pairing-heap-sort compare list-or-vector)
    209   (my-assert procedure?
    210              compare
    211              'pairing-heap-sort
    212              "expected comparison procedure for first argument, got "
    213              compare)
    214   (my-assert (lambda (obj) (or (vector? obj) (list? obj)))
    215              list-or-vector
    216              'pairing-heap-sort
    217              "expected list or vector for second argument, got "
    218              list-or-vector)
    219141  (if (list? list-or-vector)
    220142      (sort-list compare list-or-vector)
     
    223145(define (sort-list compare list)
    224146  (let ((rev-compare (lambda (obj1 obj2) (fx* -1 (compare obj1 obj2)))))
    225     (let ((h (fold %pairing-heap-insert (%pairing-heap-empty rev-compare) list)))
     147    (let ((h (fold pairing-heap-insert (pairing-heap-empty rev-compare) list)))
    226148      (let loop ((sorted-elts '())
    227149                 (h h))
    228         (if (%pairing-heap-empty? h)
     150        (if (pairing-heap-empty? h)
    229151            sorted-elts
    230             (loop (cons (%pairing-heap-min h) sorted-elts)
     152            (loop (cons (pairing-heap-min h) sorted-elts)
    231153                  (pairing-heap-remove-min h)))))))
    232154
    233155(define (sort-vector compare vec)
    234156  (let* ((n (vector-length vec))
    235          (h (let h-loop ((h (%pairing-heap-empty compare))
     157         (h (let h-loop ((h (pairing-heap-empty compare))
    236158                         (i 0))
    237159              (if (fx>= i n)
    238160                  h
    239                   (h-loop (%pairing-heap-insert (vector-ref vec i) h)
     161                  (h-loop (pairing-heap-insert (vector-ref vec i) h)
    240162                          (fx+ i 1))))))
    241163    (let ((result (make-vector n)))
     
    245167            result
    246168            (begin
    247               (vector-set! result i (%pairing-heap-min h))
     169              (vector-set! result i (pairing-heap-min h))
    248170              (result-loop (fx+ i 1) (pairing-heap-remove-min h))))))))
    249171
Note: See TracChangeset for help on using the changeset viewer.