moculus
parent
74faeb4320
commit
26b58a5c71
|
|
@ -4,23 +4,23 @@
|
|||
;;; (not (less? (list-ref list i) (list-ref list (- i 1)))).
|
||||
|
||||
(define (sorted? seq less?)
|
||||
(cond
|
||||
((null? seq)
|
||||
#t)
|
||||
((vector? seq)
|
||||
(let ((n (vector-length seq)))
|
||||
(if (<= n 1)
|
||||
#t
|
||||
(do ((i 1 (+ i 1)))
|
||||
((or (= i n)
|
||||
(less? (vector-ref seq (- i 1))
|
||||
(vector-ref seq i)))
|
||||
(= i n)) )) ))
|
||||
(else
|
||||
(let loop ((last (car seq)) (next (cdr seq)))
|
||||
(or (null? next)
|
||||
(and (not (less? (car next) last))
|
||||
(loop (car next) (cdr next)) )) )) ))
|
||||
(cond
|
||||
((null? seq)
|
||||
#t)
|
||||
((vector? seq)
|
||||
(let ((n (vector-length seq)))
|
||||
(if (<= n 1)
|
||||
#t
|
||||
(do ((i 1 (+ i 1)))
|
||||
((or (= i n)
|
||||
(less? (vector-ref seq (- i 1))
|
||||
(vector-ref seq i)))
|
||||
(= i n)) )) ))
|
||||
(else
|
||||
(let loop ((last (car seq)) (next (cdr seq)))
|
||||
(or (null? next)
|
||||
(and (not (less? (car next) last))
|
||||
(loop (car next) (cdr next)) )) )) ))
|
||||
|
||||
|
||||
;;; (merge a b less?)
|
||||
|
|
@ -30,55 +30,53 @@
|
|||
;;; Note: this does _not_ accept vectors. See below.
|
||||
|
||||
(define (merge a b less?)
|
||||
(cond
|
||||
((null? a) b)
|
||||
((null? b) a)
|
||||
(else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b)))
|
||||
;; The loop handles the merging of non-empty lists. It has
|
||||
;; been written this way to save testing and car/cdring.
|
||||
(if (less? y x)
|
||||
(if (null? b)
|
||||
(cons y (cons x a))
|
||||
(cons y (loop x a (car b) (cdr b)) ))
|
||||
;; x <= y
|
||||
(if (null? a)
|
||||
(cons x (cons y b))
|
||||
(cons x (loop (car a) (cdr a) y b)) )) )) ))
|
||||
(cond
|
||||
((null? a) b)
|
||||
((null? b) a)
|
||||
(else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b)))
|
||||
;; The loop handles the merging of non-empty lists. It has
|
||||
;; been written this way to save testing and car/cdring.
|
||||
(if (less? y x)
|
||||
(if (null? b)
|
||||
(cons y (cons x a))
|
||||
(cons y (loop x a (car b) (cdr b)) ))
|
||||
;; x <= y
|
||||
(if (null? a)
|
||||
(cons x (cons y b))
|
||||
(cons x (loop (car a) (cdr a) y b)) )) )) ))
|
||||
|
||||
|
||||
;;; (merge! a b less?)
|
||||
;;; takes two sorted lists a and b and smashes their cdr fields to form a
|
||||
;;; single sorted list including the elements of both.
|
||||
;;; Note: this does _not_ accept vectors.
|
||||
|
||||
(define (merge! a b less?)
|
||||
(define (loop r a b)
|
||||
(if (less? (car b) (car a))
|
||||
(begin
|
||||
(set-cdr! r b)
|
||||
(if (null? (cdr b))
|
||||
(set-cdr! b a)
|
||||
(loop b a (cdr b)) ))
|
||||
;; (car a) <= (car b)
|
||||
(begin
|
||||
(set-cdr! r a)
|
||||
(if (null? (cdr a))
|
||||
(set-cdr! a b)
|
||||
(loop a (cdr a) b)) )) )
|
||||
(cond
|
||||
((null? a) b)
|
||||
((null? b) a)
|
||||
((less? (car b) (car a))
|
||||
(if (null? (cdr b))
|
||||
(set-cdr! b a)
|
||||
(loop b a (cdr b)))
|
||||
b)
|
||||
(else ; (car a) <= (car b)
|
||||
(if (null? (cdr a))
|
||||
(set-cdr! a b)
|
||||
(loop a (cdr a) b))
|
||||
a)))
|
||||
|
||||
(define (loop r a b)
|
||||
(if (less? (car b) (car a))
|
||||
(begin
|
||||
(set-cdr! r b)
|
||||
(if (null? (cdr b))
|
||||
(set-cdr! b a)
|
||||
(loop b a (cdr b)) ))
|
||||
;; (car a) <= (car b)
|
||||
(begin
|
||||
(set-cdr! r a)
|
||||
(if (null? (cdr a))
|
||||
(set-cdr! a b)
|
||||
(loop a (cdr a) b)) )) )
|
||||
(cond
|
||||
((null? a) b)
|
||||
((null? b) a)
|
||||
((less? (car b) (car a))
|
||||
(if (null? (cdr b))
|
||||
(set-cdr! b a)
|
||||
(loop b a (cdr b)))
|
||||
b)
|
||||
(else ; (car a) <= (car b)
|
||||
(if (null? (cdr a))
|
||||
(set-cdr! a b)
|
||||
(loop a (cdr a) b))
|
||||
a)))
|
||||
|
||||
|
||||
;;; (sort! sequence less?)
|
||||
|
|
@ -86,49 +84,48 @@
|
|||
;;; of merge-sort invented, to the best of my knowledge, by David H. D.
|
||||
;;; Warren, and first used in the DEC-10 Prolog system. R. A. O'Keefe
|
||||
;;; adapted it to work destructively in Scheme.
|
||||
|
||||
(define (sort! seq less?)
|
||||
(define (step n)
|
||||
(cond
|
||||
((> n 2)
|
||||
(let* ((j (quotient n 2))
|
||||
(a (step j))
|
||||
(k (- n j))
|
||||
(b (step k)))
|
||||
(merge! a b less?)))
|
||||
((= n 2)
|
||||
(let ((x (car seq))
|
||||
(y (cadr seq))
|
||||
(p seq))
|
||||
(set! seq (cddr seq))
|
||||
(if (less? y x) (begin
|
||||
(set-car! p y)
|
||||
(set-car! (cdr p) x)))
|
||||
(set-cdr! (cdr p) '())
|
||||
p))
|
||||
((= n 1)
|
||||
(let ((p seq))
|
||||
(set! seq (cdr seq))
|
||||
(set-cdr! p '())
|
||||
p))
|
||||
(else
|
||||
'()) ))
|
||||
(if (vector? seq)
|
||||
(let ((n (vector-length seq))
|
||||
(vector seq)) ; save original vector
|
||||
(set! seq (vector->list seq)) ; convert to list
|
||||
(do ((p (step n) (cdr p)) ; sort list destructively
|
||||
(i 0 (+ i 1))) ; and store elements back
|
||||
((null? p) vector) ; in original vector
|
||||
(vector-set! vector i (car p)) ))
|
||||
;; otherwise, assume it is a list
|
||||
(step (length seq)) ))
|
||||
(define (step n)
|
||||
(cond
|
||||
((> n 2)
|
||||
(let* ((j (quotient n 2))
|
||||
(a (step j))
|
||||
(k (- n j))
|
||||
(b (step k)))
|
||||
(merge! a b less?)))
|
||||
((= n 2)
|
||||
(let ((x (car seq))
|
||||
(y (cadr seq))
|
||||
(p seq))
|
||||
(set! seq (cddr seq))
|
||||
(if (less? y x) (begin
|
||||
(set-car! p y)
|
||||
(set-car! (cdr p) x)))
|
||||
(set-cdr! (cdr p) '())
|
||||
p))
|
||||
((= n 1)
|
||||
(let ((p seq))
|
||||
(set! seq (cdr seq))
|
||||
(set-cdr! p '())
|
||||
p))
|
||||
(else
|
||||
'()) ))
|
||||
(if (vector? seq)
|
||||
(let ((n (vector-length seq))
|
||||
(vector seq)) ; save original vector
|
||||
(set! seq (vector->list seq)) ; convert to list
|
||||
(do ((p (step n) (cdr p)) ; sort list destructively
|
||||
(i 0 (+ i 1))) ; and store elements back
|
||||
((null? p) vector) ; in original vector
|
||||
(vector-set! vector i (car p)) ))
|
||||
;; otherwise, assume it is a list
|
||||
(step (length seq)) ))
|
||||
|
||||
|
||||
;;; (sort sequence less?)
|
||||
;;; sorts a vector or list non-destructively. It does this by sorting a
|
||||
;;; copy of the sequence
|
||||
(define (sort seq less?)
|
||||
(if (vector? seq)
|
||||
(list->vector (sort! (vector->list seq) less?))
|
||||
(sort! (append seq '()) less?)))
|
||||
(if (vector? seq)
|
||||
(list->vector (sort! (vector->list seq) less?))
|
||||
(sort! (append seq '()) less?)))
|
||||
|
|
|
|||
|
|
@ -37,6 +37,19 @@ class SchemeCheckSyntax(method.Method):
|
|||
else:
|
||||
app.data_buffer("*Scheme-Check-Syntax*", output)
|
||||
|
||||
class GuileStart(method.shell.Interact):
|
||||
args = []
|
||||
def _execute(self, w, **vargs):
|
||||
method.shell.Interact._execute(self, w, bname='*Guile*', cmd='guile')
|
||||
|
||||
class GuileLoadFile(method.shell.Interact):
|
||||
args = []
|
||||
def _execute(self, w, **vargs):
|
||||
method.shell.Interact._execute(self, w, bname='*Guile*', cmd='guile')
|
||||
b = w.application.get_buffer_by_name('*Guile*')
|
||||
path = os.path.realpath(w.buffer.path)
|
||||
b.pipe_write('(load "%s")\n' % path)
|
||||
|
||||
class Scheme(mode.Fundamental):
|
||||
modename = 'Scheme'
|
||||
extensions = ['.scm']
|
||||
|
|
@ -54,11 +67,11 @@ class Scheme(mode.Fundamental):
|
|||
'scheme_boolean': ('magenta', 'default', 'bold'),
|
||||
'scheme_number': ('default', 'default', 'bold'),
|
||||
}
|
||||
actions = [SchemeCheckSyntax]
|
||||
actions = [SchemeCheckSyntax, GuileStart, GuileLoadFile]
|
||||
_bindings = {
|
||||
'close-paren': (')',),
|
||||
'close-brace': ('}',),
|
||||
'close-bracket': (']',),
|
||||
'close-paren': (')',),
|
||||
'close-brace': ('}',),
|
||||
'close-bracket': (']',),
|
||||
'scheme-check-syntax': ('C-c s',),
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue