mike@ists.ists.ca (Mike Clarkson) (03/31/89)
#--------------------------------CUT HERE------------------------------------- #! /bin/sh # # This is a shell archive. Save this into a file, edit it # and delete all lines above this comment. Then give this # file to sh by executing the command "sh file". The files # will be extracted into the current directory owned by # you with default permissions. # # The files contained herein are: # # -rw-r--r-- 1 mike 3472 Mar 30 14:35 sort.scm # -rw-r----- 1 mike 13385 Mar 30 14:35 ti.scm # -rw-r----- 1 mike 1982 Mar 30 14:35 window.scm # echo 'x - sort.scm' if test -f sort.scm; then echo 'shar: not overwriting sort.scm'; else sed 's/^X//' << '________This_Is_The_END________' > sort.scm X;;; -*-Scheme-*- X;;; X;;; $Header: msort.scm,v 13.42 87/11/21 18:06:51 GMT jinx Rel $ X;;; X;;; Copyright (c) 1987 Massachusetts Institute of Technology X;;; X;;; This material was developed by the Scheme project at the X;;; Massachusetts Institute of Technology, Department of X;;; Electrical Engineering and Computer Science. Permission to X;;; copy this software, to redistribute it, and to use it for any X;;; purpose is granted, subject to the following restrictions and X;;; understandings. X;;; X;;; 1. Any copy made of this software must include this copyright X;;; notice in full. X;;; X;;; 2. Users of this software agree to make their best efforts (a) X;;; to return to the MIT Scheme project any improvements or X;;; extensions that they make, so that these may be included in X;;; future releases; and (b) to inform MIT of noteworthy uses of X;;; this software. X;;; X;;; 3. All materials developed as a consequence of the use of X;;; this software shall duly acknowledge such use, in accordance X;;; with the usual standards of acknowledging credit in academic X;;; research. X;;; X;;; 4. MIT has made no warrantee or representation that the X;;; operation of this software will be error-free, and MIT is X;;; under no obligation to provide any services, by way of X;;; maintenance, update, or otherwise. X;;; X;;; 5. In conjunction with products arising from the use of this X;;; material, there shall be no use of the name of the X;;; Massachusetts Institute of Technology nor of any adaptation X;;; thereof in any advertising, promotional, or sales literature X;;; without prior written consent from MIT in each case. X;;; X X;;;; Merge Sort X X(declare (usual-integrations)) X X;; Functional and unstable X X(define (sort obj #!optional pred) X (define (loop l) X (if (and (pair? l) (pair? (cdr l))) X (split l '() '()) X l)) X X (define (split l one two) X (if (pair? l) X (split (cdr l) two (cons (car l) one)) X (merge (loop one) (loop two)))) X X (define (merge one two) X (cond ((null? one) two) X ((pred (car two) (car one)) X (cons (car two) X (merge (cdr two) one))) X (else X (cons (car one) X (merge (cdr one) two))))) X X (if (unassigned? pred) (set! pred <)) X (cond ((or (pair? obj) (null? obj)) X (loop obj)) X ((vector? obj) X (sort! (vector-copy obj) pred)) X (else X (error "sort: argument should be a list or vector" obj)))) X X;; This merge sort is stable for partial orders (for predicates like X;; <=, rather than like <). X X;; This is not destructive for lists X(define (sort! v #!optional pred) X (define (sort-internal! vec temp low high) X (if (< low high) X (let* ((middle (quotient (+ low high) 2)) X (next (1+ middle))) X (sort-internal! temp vec low middle) X (sort-internal! temp vec next high) X (let loop ((p low) (p1 low) (p2 next)) X (if (not (> p high)) X (cond ((> p1 middle) X (vector-set! vec p (vector-ref temp p2)) X (loop (1+ p) p1 (1+ p2))) X ((or (> p2 high) X (pred (vector-ref temp p1) X (vector-ref temp p2))) X (vector-set! vec p (vector-ref temp p1)) X (loop (1+ p) (1+ p1) p2)) X (else X (vector-set! vec p (vector-ref temp p2)) X (loop (1+ p) p1 (1+ p2))))))))) X X (if (unassigned? pred) (set! pred <)) X (cond ((list? obj) X (writeln "Warning: SORT! is not destructive on lists." v) X (set! v (vector->list v))) X ((not (vector? v)) X (error "sort!: argument not a vector or list." v))) X X (sort-internal! v X (vector-copy v) X 0 X (-1+ (vector-length v))) ________This_Is_The_END________ if test `wc -l < sort.scm` -ne 109; then echo 'shar: sort.scm was damaged during transit (should have been 109 lines)' fi fi ; : end of overwriting check echo 'x - ti.scm' if test -f ti.scm; then echo 'shar: not overwriting ti.scm'; else sed 's/^X//' << '________This_Is_The_END________' > ti.scm X(declare (usual-integrations)) X X;; Some required and worthwile definitions X(define file-attributes (make-primitive-procedure 'FILE-ATTRIBUTES)) X X(in-package system-global-environment X (define (add-syntax! name expander) X (SYNTAX-TABLE-DEFINE SYSTEM-GLOBAL-SYNTAX-TABLE name expander) X name) X ) X X;; Extend the parser to recognize | X(load "$TISCHEME/parser-escape" parser-package) X X(define (not-implemented-yet name) X (error "Not implemented yet" name)) X X;; Set up autoloading first X;;; AUTOLOAD-FROM-FILE X(load "$TISCHEME/auto-load") X X;;; ADD1 X(define add1 1+) X X;;; ALIAS X X;;; ALL-CLASSVARS X(autoload-from-file "$TISCHEME/scoops" '(all-classvars)) X X;;; ALL-INSTVARS X(autoload-from-file "$TISCHEME/scoops" '(all-instvars)) X X;;; ALL-METHODS X(autoload-from-file "$TISCHEME/scoops" '(all-methods)) X X;;; APPLY-IF X(syntax-table-define system-global-syntax-table 'APPLY-IF X (macro (pred proc exp) X `(let ((t1 ,pred) (t2 (lambda () ,exp))) X (if t1 (,proc t1) X (t2))))) X X;;; ASCII->SYMBOL X;; This is not really the same. TI's (ASCII->SYMBOL 39) returns |'| X;; This one returns ' X(define (ascii->symbol number) X (if (and (integer? number) (positive? number) (<= number 255)) X (string->symbol (char->string (ascii->char 39))) X (error "ASCII->SYMBOL: Not an integer between 0 and 255" number))) X X;;; ASSERT X(define (assert predicate . messages) X (not-implemented-yet 'ASSERT)) X X;;; ATOM? X(define (atom? object) X (not (pair? object))) X X X;;; ATAN X(let () X (let-syntax () X (define-macro (define-primitives . names) X `(BEGIN ,@(map (lambda (name) X `(LOCAL-ASSIGNMENT X (the-environment) X ',name X ,(make-primitive-procedure name))) X names))) X (define-primitives &= &< &> &+ &- &* &/ &atan)) X X (declare (integrate-primitive-procedures X &= &< &> &+ &- &* &/ &atan)) X X (define pi/4 (&atan 1)) X (define pi/2 (&* pi/4 2)) X (define -pi/2 (&- 0 pi/2)) X (define pi (&* pi/4 4)) X X (set! atan X (named-lambda (atan y #!optional x) X (if (unassigned? x) (set! x 1)) X (if (zero? x) X (if (negative? y) -pi/2 pi/2) X (let ((atan1 (&atan (&/ y x)))) X (cond ((positive? x) atan1) X ((negative? y) (&- atan1 pi)) X (else (&+ atan1 pi))))))) X ) X X;;; BEGIN0 X(define-macro (begin0 first . rest) X `(let ((temp ,first)) ,@rest temp)) X X;;; CALL/CC X(define call/cc call-with-current-continuation) X X;;; CLASS-COMPILED? X(autoload-from-file "$TISCHEME/scoops" '(class-compiled?)) X X;;; CLASS-OF-OBJECT X(autoload-from-file "$TISCHEME/scoops" '(class-of-object)) X X;;; CLASSVARS X(autoload-from-file "$TISCHEME/scoops" '(classvars)) X X;;; CLEAR-GRAPHICS X(autoload-from-file "$TISCHEME/graphics" '(clear-graphics)) X X;;; CLEAR-POINT X(autoload-from-file "$TISCHEME/graphics" '(clear-point)) X X;;; CLOSURE? X(define closure? procedure?) X X;;; COMPILE-CLASS X(autoload-from-file "$TISCHEME/scoops" '(compile-class)) X X;;; COMPILE-FILE X(define compile-file sf) X X;;; CURRENT-COLUMN X(define (current-column #!optional port) X (cond ((unassigned? port) (set! port *current-input-port*)) X ((not (port? port)) (error "FLUSH-INPUT: Bad port" port))) X (not-implemented-yet 'CURRENT-COLUMN)) X X;;; DEFINE-CLASS X(autoload-from-file "$TISCHEME/scoops" '(define-class)) X X;;; DEFINE-INTEGRABLE X(syntax-table-define system-global-syntax-table 'DEFINE-INTEGRABLE X (macro (pattern . body) X `(BEGIN (DECLARE (INTEGRATE-OPERATOR ,(car pattern))) X (DEFINE ,pattern X (DECLARE (INTEGRATE ,@(cdr pattern))) X ,@body)))) X X X;;; DEFINE-METHOD X(autoload-from-file "$TISCHEME/scoops" '(define-method)) X X;;; DESCRIBE X(autoload-from-file "$TISCHEME/scoops" '(describe)) X X;;; DELAYED-OBJECT? X(define delayed-object? X (microcode-type-predicate 'DELAYED)) X X;;; DOS-CHDIR X(define (dos-chdir pathname) X (set-working-directory-pathname! X (cond ((pathname? pathname) pathname) X ((symbol? pathname) (symbol->pathname pathname)) X ((string=? pathname ".") X (working-directory-pathname)) X ((string=? pathname "..") X (make-pathname X (pathname-device (%pwd)) X (simplify-directory X (append (pathname-directory (%pwd)) '(UP))) X false X false X false)) X ((string? pathname) X (string->pathname pathname)) X (else (error "DOS-CHDIR: Not a pathname, symbol or string"))))) X X X X X;;; DOS-COPY-FILE X(define dos-file-copy copy-file) X X;;; DOS-DELETE X(define dos-delete delete-file) X X;;; DOS-FILE-SIZE X(define (dos-file-size filename) X (if (file-exists? filename) X (vector-ref (file-attributes filename) 7))) X X;;; DOS-RENAME X(define dos-rename rename-file) X X;;; DRAW-BOX-TO X(autoload-from-file "$TISCHEME/graphics" '(draw-box-to)) X X;;; DRAW-FILLED-BOX-TO X(autoload-from-file "$TISCHEME/graphics" '(draw-filled-box-to)) X X;;; DRAW-LINE-TO X(autoload-from-file "$TISCHEME/graphics" '(draw-line-to)) X X;;; DRAW-POINT X(autoload-from-file "$TISCHEME/graphics" '(draw-point)) X X;;; EDIT X(define (edit pair) X (not-implemented-yet 'EDIT)) X X;;; EDWIN X(define (edwin) X (not-implemented-yet 'EDWIN)) X X;;; ENGINE-RETURN X(define (engine-return val) X (not-implemented-yet 'ENGINE-RETURN)) X X;;; #\ESCAPE X(load "$TISCHEME/escape") X X(define (eval expression #!optional environment) X (if (unassigned? environment) (set! environment *rep-current-environment*)) X (scode-eval (syntax expression *rep-current-syntax-table*) X environment)) X X;;; EXIT X(define exit %exit) X X;;; EXPLODE X(autoload-from-file "$SCHEME/xplode" '(explode)) X X;;; FLUSH-INPUT X(define (flush-input #!optional port) X (let ((newline-delimiters (char-set #\Newline))) X (cond ((unassigned? port) (set! port *current-input-port*)) X ((not (port? port)) (error "FLUSH-INPUT: Bad port" port))) X (or ((access :discard-chars port) newline-delimiters) X eof-object))) X X;;; FREESP X(define (freesp) X (vector-ref (car (gc-statistics)) 5)) X X;;; FRESH-LINE X(define (fresh-line #!optional port) X (cond ((unassigned? port) (set! port *current-output-port*)) X ((not (port? port)) (error "Bad port" port))) X (not-implemented-yet 'FRESH-LINE)) X X;;; GC X(define gc gc-flip) X X;;; GENSYM X;; Make gensym a version of generate-uninterned-symbol that accepts X;; a number or a string, as well as a symbol as the optional argument X(define gensym X (let ((name-counter 0) X (name-prefix "G")) X (define (get-number) X (let ((result name-counter)) X (set! name-counter (1+ name-counter)) X result)) X (named-lambda (gensym #!optional argument) X (if (not (unassigned? argument)) X (cond ((string? argument) X (set! name-prefix argument)) X ((symbol? argument) X (set! name-prefix (symbol->string argument))) X ((integer? argument) X (set! name-counter argument)) X (else X (error "Bad argument: GENSYM" X argument)))) X (string->uninterned-symbol X (string-append name-prefix (write-to-string (get-number))))))) X X;;; GETCV X(autoload-from-file "$TISCHEME/scoops" '(getcv)) X X;;; GET-FILE-POSITION X;; Not implemented yet - needs C support X(define (get-file-position port) X (if (not (port? port)) (error "Bad port" port)) X (not-implemented-yet 'GET-FILE-POSITION)) X X;;; GET-PEN-COLOR X(autoload-from-file "$TISCHEME/graphics" '(get-pen-color)) X X;;; GETPROP X(define getprop 2D-get) X X;;; GET-VIDEO-MODE X(autoload-from-file "$TISCHEME/graphics" '(get-video-mode)) X X;;; *GRAPHICS-COLORS* X(autoload-from-file "$TISCHEME/graphics" '(*graphics-colors*)) X X;;; IF X(set! undefined-conditional-branch '()) X X;;; IMPLODE X(autoload-from-file "$scheme/xplode" '(implode)) X X;;; INSTVARS X(autoload-from-file "$TISCHEME/scoops" '(instvars)) X X;;; INTEGER->STRING X(define (integer->string number base) X (cond ((not (integer? number)) X (error "INTEGER->STRING: Not an integer" number)) X ((not (integer? base)) X (error "INTEGER->STRING: Not an integer" base)) X (else (list->string X (fluid-let ((*radix* base)) X ((access unparse-signed-integer X number-unparser-package) number)))))) X X;;; IS-POINT-ON? X(autoload-from-file "$TISCHEME/graphics" '(is-point-on?)) X X;;; LINE-LENGTH X(define (line-length #!optional port) X (cond ((unassigned? port) (set! port *current-output-port*)) X ((not (port? port)) (error "Bad port" port))) X ((access :x-size port))) X X;;; LIST* X(define list* cons*) X X;;; LIST->STREAM X;; This may be wrong. (cons (car obj) (delay (cdr obj))) ?? X(define (list->stream obj) X (if (not (list? obj)) (error "LIST->STREAM: Not a list" obj)) X (let loop ((lyst obj) X (result)) X (if (null? lyst) X (reverse! result) X (loop (cdr lyst) (cons-stream (car lyst) result))))) X X;;; MACRO X;; TI's macro conflicts with MIT's macro. X;; TI's MACRO has been renamed to ti-macro X(add-syntax! 'ti-macro X (macro (symbol def) X (let ((var (caadr def)) X (body (cddr def))) X `(add-syntax! X ',symbol X (macro ,var X (let ((,var (cons ',symbol ,var))) X ,@body)))))) X X;;; MAKE-ENGINE X(define (make-engine thunk) X (not-implemented-yet 'MAKE-ENGINE)) X X;;; MAKE-INSTANCE X(autoload-from-file "$TISCHEME/scoops" '(make-instance)) X X;;; MAKE-WINDOW X(autoload-from-file "$TISCHEME/window" '(make-window)) X X;;; METHODS X;;; MIXINS X;;; NAME->CLASS X(autoload-from-file "$TISCHEME/scoops" '(methods mixins name->class)) X X;;; NIL X(define nil '()) X X;;; OPEN-BINARY-INPUT-FILE X(define open-binary-input-file open-input-file) X X;;; OPEN-BINARY-OUTPUT-FILE X(define open-binary-output-file open-output-file) X X;;; OPEN-EXTEND-FILE X;; Not implemented yet - needs C support X(autoload-from-file "$TISCHEME/file-extend" '(open-extend-file)) X X;;; PI X(define pi (* 4.0 (atan 1.0 1.0))) X X;;; POINT-COLOR X(autoload-from-file "$TISCHEME/graphics" '(point-color)) X X;;; PORT? X(define (port? port) X (or (output-port? port) X (input-port? port))) X X;;; POSITION-PEN X(autoload-from-file "$TISCHEME/graphics" '(position-pen)) X X;;; PRINC X(define princ display) X X;;; PRIN1 X(define prin1 write) X X;;; PRINT X(define (print object #!optional port) X (cond ((unassigned? port) (set! port *current-output-port*)) X ((not (output-port? port)) (error "Bad output port" port))) X (newline port) X (write object port) X (write " " port) X *the-non-printing-object*) X X;;; PRINT-LENGTH X(define (print-length object) X (string-length X (with-output-to-string X (lambda () X (display object))))) X X;;; PROC? X(define (proc? object) X (or (procedure? object) (continuation? object))) X X;;; PROPLIST X(define proplist 2d-get-alist-x) X X;;; PUTPROP X(define (putprop name val prop) X (2D-put! name prop val)) X X;;; READ-ATOM X(define (read-atom #!optional port) X (let ((atom-delimiters (access atom-delimiters parser-package))) X (cond ((unassigned? port) (set! port *current-input-port*)) X ((not (port? port)) (error "READ-ATOM: Bad port" port))) X (or ((access :read-string port) atom-delimiters) X eof-object))) X X;;; READ-LINE X(define (read-line #!optional port) X (let ((newline-delimiters (char-set #\Newline))) X (cond ((unassigned? port) (set! port *current-input-port*)) X ((not (port? port)) (error "READ-LINE: Bad port" port))) X (or ((access :read-string port) newline-delimiters) X eof-object))) X X;;; REC X;; You may want to change REC of lambdas to named lambdas X(syntax-table-define system-global-syntax-table 'REC X (macro (var exp) X `(letrec ((,var ,exp)) ,var))) X X;;; REMPROP X(define remprop 2D-remove!) X X;;; RENAME-CLASS X;;; SEND X;;; SEND-IF-HANDLES X(autoload-from-file "$TISCHEME/scoops" '(rename-class send send-if-handles)) X X;;; SET-LINE-LENGTH! X(define (set-line-length! number #!optional port) X (cond ((unassigned? port) (set! port *current-output-port*)) X ((not (port? port)) (error "SET-LINE-LENGTH!: Bad port" port))) X (if (not (and (integer? number) (>= number 0))) X (error "SET-LINE-LENGTH!: number must be a positive integer" number)) X (set! (access :x-size port) `(lambda () ,number))) X X;;; SET! X;; (SET! (VECTOR-REF vector n) value) is not implemented yet. X;; (SET! (FLUID var) value) is not implemented yet. X X;;; SETCV X(autoload-from-file "$TISCHEME/scoops" '(setcv)) X X;;; SORT X(load "$TISCHEME/sort") X X;;; STREAM? X(define (stream? obj) X (and (pair? obj) X (delayed? (cdr obj)))) X X;;; STREAM->LIST X(define (stream->list obj) X (if (not (stream? obj)) (error "STREAM->LIST: Not a stream" obj)) X (let loop ((stream obj) X (result)) X (if (empty-stream? stream) X (reverse! result) X (loop (force (cdr stream)) (cons (car stream) result))))) X X;;; SUB1 X(define sub1 -1+) X X;;; SYMBOL->ASCII X(define (symbol->ascii symbol) X (char->ascii (car (string->list (symbol->string symbol))))) X X;;; SYNTAX X;; Confilicts with MIT definition X X;;; T X(define t #!true) X X;;; WHEN X(syntax-table-define system-global-syntax-table 'WHEN X (macro args X `(if ,(car args) X (begin ,@(cdr args))))) X X;;; WINDOW-CLEAR X;;; WINDOW-DELETE X;;; WINDOW-GET-ATTRIBUTE X;;; WINDOW-GET-CURSOR X;;; WINDOW-GET-POSITION X;;; WINDOW-GET-SIZE X;;; WINDOW-POPUP X;;; WINDOW-POPUP-DELETE X;;; WINDOW-RESTORE-CONTENTS X;;; WINDOW-SAVE-CONTENTS X;;; WINDOW-SET-ATTRIBUTE! X;;; WINDOW-SET-CURSOR! X;;; WINDOW-SET-POSITION! X;;; WINDOW-SET-SIZE! X;;; WINDOW? X X(autoload-from-file "$TISCHEME/window" '(window-clear window-delete Xwindow-get-attribute window-get-cursor window-get-position window-get-size Xwindow-popup window-popup-delete window-restore-contents Xwindow-save-contents window-set-attribute! window-set-cursor! Xwindow-set-position! window-set-size! window?)) X X;;; WRITELN X(define (writeln #!rest objects) X (for-each display objects) X (newline)) X X(newline) X(define (ti-compatibility-package-version) X "1.0") X X(writeln "TI Functions loaded.") ________This_Is_The_END________ if test `wc -l < ti.scm` -ne 532; then echo 'shar: ti.scm was damaged during transit (should have been 532 lines)' fi fi ; : end of overwriting check echo 'x - window.scm' if test -f window.scm; then echo 'shar: not overwriting window.scm'; else sed 's/^X//' << '________This_Is_The_END________' > window.scm X(declare (usual-integrations)) X X;;; MAKE-WINDOW X(define (make-window #!optional label border) X (not-implemented-yet 'make-window)) X X;;; WINDOW-CLEAR X(define (window-clear window) X (not-implemented-yet 'window-clear)) X X;;; WINDOW-DELETE X(define (window-delete window) X (not-implemented-yet 'window-delete)) X X;;; WINDOW-GET-ATTRIBUTE X(define (window-get-attribute window name) X (case name X (BORDER-ATTRIBUTES) X (TEXT-ATTRIBUTES) X (WINDOW-FLAGS) X (else (error "WINDOW-GET-ATTRIBUTE: Unknown attribute" name))) X (not-implemented-yet 'window-get-attribute)) X X;;; WINDOW-GET-CURSOR X(define (window-get-cursor window) X (not-implemented-yet 'window-get-cursor)) X X;;; WINDOW-GET-POSITION X(define (window-get-position window) X (not-implemented-yet 'window-get-position)) X X;;; WINDOW-GET-SIZE X(define (window-get-size window) X (not-implemented-yet 'window-get-size)) X X;;; WINDOW-POPUP X(define (window-popup window) X (not-implemented-yet 'window-popup)) X X;;; WINDOW-POPUP-DELETE X(define (window-popup-delete window) X (not-implemented-yet 'window-popup-delete)) X X;;; WINDOW-RESTORE-CONTENTS X(define (window-restore-contents window contents) X (not-implemented-yet 'window-restore-contents)) X X;;; WINDOW-SAVE-CONTENTS X(define (window-save-contents window) X (not-implemented-yet 'window-save-contents)) X X;;; WINDOW-SET-ATTRIBUTE! X(define (window-set-attribute! window name value) X (case name X (BORDER-ATTRIBUTES) X (TEXT-ATTRIBUTES) X (WINDOW-FLAGS) X (else (error "WINDOW-SET-ATTRIBUTE!: Unknown attribute" name))) X (not-implemented-yet 'window-set-attribute!)) X X;;; WINDOW-SET-CURSOR! X(define (window-set-cursor! window line col) X (not-implemented-yet 'window-set-cursor!)) X X;;; WINDOW-SET-POSITION! X(define (window-set-position! window line col) X (not-implemented-yet 'window-set-position!)) X X;;; WINDOW-SET-SIZE! X(define (window-set-size! window lines cols) X (not-implemented-yet 'window-set-size!)) X X;;; WINDOW? X(define (window? obj) X (not-implemented-yet 'window?)) X ________This_Is_The_END________ if test `wc -l < window.scm` -ne 76; then echo 'shar: window.scm was damaged during transit (should have been 76 lines)' fi fi ; : end of overwriting check exit 0 -- Mike Clarkson mike@ists.UUCP Institute for Space and Terrestrial Science mike@ists.ists.ca York University, North York, Ontario, uunet!mnetor!yunexus!ists!mike CANADA M3J 1P3 +1 (416) 736-5611