d6
/
pmacs3
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

--HG-- 

branch : pmacs2
This commit is contained in:
moculus 2009-03-04 06:53:26 +00:00
parent 74faeb4320
commit 26b58a5c71
2 changed files with 112 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

193
code_examples/sorts.scm
View File

@ -4,23 +4,23 @@
;;; (not (less? (list-ref list i) (list-ref list (- i 1)))). ;;; (not (less? (list-ref list i) (list-ref list (- i 1)))).
(define (sorted? seq less?) (define (sorted? seq less?)
(cond (cond
((null? seq) ((null? seq)
#t) #t)
((vector? seq) ((vector? seq)
(let ((n (vector-length seq))) (let ((n (vector-length seq)))
(if (<= n 1) (if (<= n 1)
#t #t
(do ((i 1 (+ i 1))) (do ((i 1 (+ i 1)))
((or (= i n) ((or (= i n)
(less? (vector-ref seq (- i 1)) (less? (vector-ref seq (- i 1))
(vector-ref seq i))) (vector-ref seq i)))
(= i n)) )) )) (= i n)) )) ))
(else (else
(let loop ((last (car seq)) (next (cdr seq))) (let loop ((last (car seq)) (next (cdr seq)))
(or (null? next) (or (null? next)
(and (not (less? (car next) last)) (and (not (less? (car next) last))
(loop (car next) (cdr next)) )) )) )) (loop (car next) (cdr next)) )) )) ))
;;; (merge a b less?) ;;; (merge a b less?)
@ -30,55 +30,53 @@
;;; Note: this does _not_ accept vectors. See below. ;;; Note: this does _not_ accept vectors. See below.
(define (merge a b less?) (define (merge a b less?)
(cond (cond
((null? a) b) ((null? a) b)
((null? b) a) ((null? b) a)
(else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b))) (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 ;; The loop handles the merging of non-empty lists. It has
;; been written this way to save testing and car/cdring. ;; been written this way to save testing and car/cdring.
(if (less? y x) (if (less? y x)
(if (null? b) (if (null? b)
(cons y (cons x a)) (cons y (cons x a))
(cons y (loop x a (car b) (cdr b)) )) (cons y (loop x a (car b) (cdr b)) ))
;; x <= y ;; x <= y
(if (null? a) (if (null? a)
(cons x (cons y b)) (cons x (cons y b))
(cons x (loop (car a) (cdr a) y b)) )) )) )) (cons x (loop (car a) (cdr a) y b)) )) )) ))
;;; (merge! a b less?) ;;; (merge! a b less?)
;;; takes two sorted lists a and b and smashes their cdr fields to form a ;;; takes two sorted lists a and b and smashes their cdr fields to form a
;;; single sorted list including the elements of both. ;;; single sorted list including the elements of both.
;;; Note: this does _not_ accept vectors. ;;; Note: this does _not_ accept vectors.
(define (merge! a b less?) (define (merge! a b less?)
(define (loop r a b) (define (loop r a b)
(if (less? (car b) (car a)) (if (less? (car b) (car a))
(begin (begin
(set-cdr! r b) (set-cdr! r b)
(if (null? (cdr b)) (if (null? (cdr b))
(set-cdr! b a) (set-cdr! b a)
(loop b a (cdr b)) )) (loop b a (cdr b)) ))
;; (car a) <= (car b) ;; (car a) <= (car b)
(begin (begin
(set-cdr! r a) (set-cdr! r a)
(if (null? (cdr a)) (if (null? (cdr a))
(set-cdr! a b) (set-cdr! a b)
(loop a (cdr a) b)) )) ) (loop a (cdr a) b)) )) )
(cond (cond
((null? a) b) ((null? a) b)
((null? b) a) ((null? b) a)
((less? (car b) (car a)) ((less? (car b) (car a))
(if (null? (cdr b)) (if (null? (cdr b))
(set-cdr! b a) (set-cdr! b a)
(loop b a (cdr b))) (loop b a (cdr b)))
b) b)
(else ; (car a) <= (car b) (else ; (car a) <= (car b)
(if (null? (cdr a)) (if (null? (cdr a))
(set-cdr! a b) (set-cdr! a b)
(loop a (cdr a) b)) (loop a (cdr a) b))
a))) a)))
;;; (sort! sequence less?) ;;; (sort! sequence less?)
@ -86,49 +84,48 @@
;;; of merge-sort invented, to the best of my knowledge, by David H. D. ;;; 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 ;;; Warren, and first used in the DEC-10 Prolog system. R. A. O'Keefe
;;; adapted it to work destructively in Scheme. ;;; adapted it to work destructively in Scheme.
(define (sort! seq less?) (define (sort! seq less?)
(define (step n) (define (step n)
(cond (cond
((> n 2) ((> n 2)
(let* ((j (quotient n 2)) (let* ((j (quotient n 2))
(a (step j)) (a (step j))
(k (- n j)) (k (- n j))
(b (step k))) (b (step k)))
(merge! a b less?))) (merge! a b less?)))
((= n 2) ((= n 2)
(let ((x (car seq)) (let ((x (car seq))
(y (cadr seq)) (y (cadr seq))
(p seq)) (p seq))
(set! seq (cddr seq)) (set! seq (cddr seq))
(if (less? y x) (begin (if (less? y x) (begin
(set-car! p y) (set-car! p y)
(set-car! (cdr p) x))) (set-car! (cdr p) x)))
(set-cdr! (cdr p) '()) (set-cdr! (cdr p) '())
p)) p))
((= n 1) ((= n 1)
(let ((p seq)) (let ((p seq))
(set! seq (cdr seq)) (set! seq (cdr seq))
(set-cdr! p '()) (set-cdr! p '())
p)) p))
(else (else
'()) )) '()) ))
(if (vector? seq) (if (vector? seq)
(let ((n (vector-length seq)) (let ((n (vector-length seq))
(vector seq)) ; save original vector (vector seq)) ; save original vector
(set! seq (vector->list seq)) ; convert to list (set! seq (vector->list seq)) ; convert to list
(do ((p (step n) (cdr p)) ; sort list destructively (do ((p (step n) (cdr p)) ; sort list destructively
(i 0 (+ i 1))) ; and store elements back (i 0 (+ i 1))) ; and store elements back
((null? p) vector) ; in original vector ((null? p) vector) ; in original vector
(vector-set! vector i (car p)) )) (vector-set! vector i (car p)) ))
;; otherwise, assume it is a list ;; otherwise, assume it is a list
(step (length seq)) )) (step (length seq)) ))
;;; (sort sequence less?) ;;; (sort sequence less?)
;;; sorts a vector or list non-destructively. It does this by sorting a ;;; sorts a vector or list non-destructively. It does this by sorting a
;;; copy of the sequence ;;; copy of the sequence
(define (sort seq less?) (define (sort seq less?)
(if (vector? seq) (if (vector? seq)
(list->vector (sort! (vector->list seq) less?)) (list->vector (sort! (vector->list seq) less?))
(sort! (append seq '()) less?))) (sort! (append seq '()) less?)))

21
mode/scheme.py
View File

@ -37,6 +37,19 @@ class SchemeCheckSyntax(method.Method):
else: else:
app.data_buffer("*Scheme-Check-Syntax*", output) 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): class Scheme(mode.Fundamental):
modename = 'Scheme' modename = 'Scheme'
extensions = ['.scm'] extensions = ['.scm']
@ -54,11 +67,11 @@ class Scheme(mode.Fundamental):
'scheme_boolean': ('magenta', 'default', 'bold'), 'scheme_boolean': ('magenta', 'default', 'bold'),
'scheme_number': ('default', 'default', 'bold'), 'scheme_number': ('default', 'default', 'bold'),
} }
actions = [SchemeCheckSyntax] actions = [SchemeCheckSyntax, GuileStart, GuileLoadFile]
_bindings = { _bindings = {
'close-paren': (')',), 'close-paren': (')',),
'close-brace': ('}',), 'close-brace': ('}',),
'close-bracket': (']',), 'close-bracket': (']',),
'scheme-check-syntax': ('C-c s',), 'scheme-check-syntax': ('C-c s',),
} }