94 lines
2.8 KiB
Racket
94 lines
2.8 KiB
Racket
#lang racket/load
|
|
|
|
(module raw-sort racket
|
|
(define (insert <= e l)
|
|
(cond
|
|
[(empty? l)
|
|
(list e)]
|
|
[(<= e (first l))
|
|
(list* e l)]
|
|
[else
|
|
(list* (first l)
|
|
(insert <= e (rest l)))]))
|
|
(define (sort <= l)
|
|
(if (empty? l)
|
|
empty
|
|
(insert <= (first l)
|
|
(sort <= (rest l)))))
|
|
(provide sort))
|
|
|
|
(module ctc-sort racket
|
|
(require 'raw-sort)
|
|
(provide/contract
|
|
[sort (-> (-> any/c any/c boolean?)
|
|
(listof any/c)
|
|
(listof any/c))]))
|
|
|
|
(module qdsl-sort racket
|
|
(require unstable/temp-c/dsl 'raw-sort unstable/match)
|
|
(provide make-sort)
|
|
(define (make-sort)
|
|
(contract
|
|
(with-monitor (label 'sort (-> (label 'order (-> any/c any/c boolean?))
|
|
(listof any/c)
|
|
(listof any/c)))
|
|
(complement
|
|
(seq (star _)
|
|
(dseq
|
|
(monitor:proj 'order proj _)
|
|
(seq (star _)
|
|
(monitor:return 'sort _ _ _ _ _ _ _) (star _)
|
|
(monitor:call 'order (== proj) _ _ _ _ _))))))
|
|
sort 'pos 'neg)))
|
|
|
|
(module dsl-sort racket
|
|
(require unstable/temp-c/dsl 'raw-sort)
|
|
(provide make-sort)
|
|
(define (make-sort)
|
|
(contract (with-monitor (label 'sort (-> (label 'order (-> any/c any/c boolean?))
|
|
(listof any/c)
|
|
(listof any/c)))
|
|
(complement
|
|
(seq (star _)
|
|
(monitor:proj 'order _ _) (star _)
|
|
(monitor:return 'sort _ _ _ _ _ _ _) (star _)
|
|
(monitor:call 'order _ _ _ _ _ _))))
|
|
sort
|
|
'pos 'neg)))
|
|
|
|
(module smart-sort racket
|
|
(require unstable/temp-c/monitor 'raw-sort)
|
|
(define returned? #f)
|
|
(define (sort-monitor evt)
|
|
(match evt
|
|
[(monitor:proj 'order proj _)
|
|
#t]
|
|
[(monitor:return 'sort _ _ _ _ _ (list f _) _)
|
|
(set! returned? #t)]
|
|
[(monitor:call 'order proj _ _ _ _ _)
|
|
(not returned?)]
|
|
[_ #t]))
|
|
(provide/contract
|
|
[sort (monitor/c sort-monitor 'sort
|
|
(-> (monitor/c sort-monitor 'order (-> any/c any/c boolean?))
|
|
(listof any/c)
|
|
(listof any/c)))]))
|
|
|
|
(module sort-timer racket
|
|
(require (prefix-in dsl: 'dsl-sort)
|
|
(prefix-in qdsl: 'qdsl-sort)
|
|
(prefix-in smart: 'smart-sort)
|
|
(prefix-in raw: 'raw-sort)
|
|
(prefix-in ctc: 'ctc-sort)
|
|
tests/stress)
|
|
|
|
(define l (build-list 200 (compose random add1)))
|
|
(stress 1
|
|
["raw" (raw:sort <= l)]
|
|
["ctc" (ctc:sort <= l)]
|
|
["qdsl" ((qdsl:make-sort) <= l)]
|
|
["dsl" ((dsl:make-sort) <= l)]
|
|
["smart" (smart:sort <= l)]))
|
|
|
|
(require 'sort-timer)
|