diff --git a/collects/deinprogramm/DMdA-advanced-reader.ss b/collects/deinprogramm/DMdA-advanced-reader.ss new file mode 100644 index 0000000000..38eb173ee0 --- /dev/null +++ b/collects/deinprogramm/DMdA-advanced-reader.ss @@ -0,0 +1,7 @@ +#lang scheme/base +(require deinprogramm/DMdA-reader) +(provide (rename-out (-read-syntax read-syntax)) + (rename-out (-read read))) +(define -read-syntax (make-read-syntax '(lib "DMdA-advanced.ss" "deinprogramm"))) +(define -read (make-read '(lib "DMdA-advanced.ss" "deinprogramm"))) + diff --git a/collects/deinprogramm/DMdA-advanced.ss b/collects/deinprogramm/DMdA-advanced.ss new file mode 100644 index 0000000000..99ffbe8285 --- /dev/null +++ b/collects/deinprogramm/DMdA-advanced.ss @@ -0,0 +1,20 @@ +#lang deinprogramm/DMdA + +(require syntax/docprovide) +(provide #%app #%top (rename-out (DMdA-module-begin #%module-begin)) #%datum #%top-interaction require lib planet + let let* letrec + (rename-out (DMdA-advanced-lambda lambda)) + (rename-out (DMdA-advanced-define define)) + cond if else begin and or set! quote + define-record-procedures define-record-procedures-2 + define-record-procedures-parametric define-record-procedures-parametric-2 + .. ... .... ..... ...... + check-expect check-within check-error + : define-contract -> mixed one-of predicate combined property + number real rational integer natural boolean true false string symbol empty-list unspecific + chocolate-cookie) +(provide cons) +(provide-and-document + procedures + (all-from advanced: deinprogramm/DMdA procedures)) + diff --git a/collects/deinprogramm/DMdA-advanced/lang/reader.ss b/collects/deinprogramm/DMdA-advanced/lang/reader.ss new file mode 100644 index 0000000000..9232389026 --- /dev/null +++ b/collects/deinprogramm/DMdA-advanced/lang/reader.ss @@ -0,0 +1,2 @@ +(module reader syntax/module-reader + deinprogramm/DMdA-advanced) diff --git a/collects/deinprogramm/DMdA-assignments-reader.ss b/collects/deinprogramm/DMdA-assignments-reader.ss new file mode 100644 index 0000000000..ac06aa6167 --- /dev/null +++ b/collects/deinprogramm/DMdA-assignments-reader.ss @@ -0,0 +1,8 @@ +#lang scheme/base +(require deinprogramm/DMdA-reader) +(provide (rename-out (-read-syntax read-syntax)) + (rename-out (-read read))) +(define -read-syntax (make-read-syntax '(lib "DMdA-assignments.ss" "deinprogramm"))) +(define -read (make-read '(lib "DMdA-assignments.ss" "deinprogramm"))) + + diff --git a/collects/deinprogramm/DMdA-assignments.ss b/collects/deinprogramm/DMdA-assignments.ss new file mode 100644 index 0000000000..b7c29053ec --- /dev/null +++ b/collects/deinprogramm/DMdA-assignments.ss @@ -0,0 +1,19 @@ +#lang deinprogramm/DMdA + +(require syntax/docprovide) +(provide #%app #%top (rename-out (DMdA-module-begin #%module-begin)) #%datum #%top-interaction require lib planet + let let* letrec + (rename-out (DMdA-advanced-lambda lambda)) + (rename-out (DMdA-advanced-define define)) + cond if else begin and or set! + define-record-procedures define-record-procedures-2 + define-record-procedures-parametric define-record-procedures-parametric-2 + .. ... .... ..... ...... + check-expect check-within check-error + : define-contract -> mixed one-of predicate combined property + number real rational integer natural boolean true false string empty-list unspecific + chocolate-cookie) +(provide cons) +(provide-and-document + procedures + (all-from assignments: deinprogramm/DMdA procedures)) diff --git a/collects/deinprogramm/DMdA-assignments/lang/reader.ss b/collects/deinprogramm/DMdA-assignments/lang/reader.ss new file mode 100644 index 0000000000..0785b2a531 --- /dev/null +++ b/collects/deinprogramm/DMdA-assignments/lang/reader.ss @@ -0,0 +1,2 @@ +(module reader syntax/module-reader + deinprogramm/DMdA-assignments) diff --git a/collects/deinprogramm/DMdA-beginner-reader.ss b/collects/deinprogramm/DMdA-beginner-reader.ss new file mode 100644 index 0000000000..42c7394f7b --- /dev/null +++ b/collects/deinprogramm/DMdA-beginner-reader.ss @@ -0,0 +1,7 @@ +#lang scheme/base +(require deinprogramm/DMdA-reader) +(provide (rename-out (-read-syntax read-syntax)) + (rename-out (-read read))) +(define -read-syntax (make-read-syntax '(lib "DMdA-beginner.ss" "deinprogramm"))) +(define -read (make-read '(lib "DMdA-beginner.ss" "deinprogramm"))) + diff --git a/collects/deinprogramm/DMdA-beginner.ss b/collects/deinprogramm/DMdA-beginner.ss new file mode 100644 index 0000000000..f448e046c1 --- /dev/null +++ b/collects/deinprogramm/DMdA-beginner.ss @@ -0,0 +1,21 @@ +#lang deinprogramm/DMdA + +(require syntax/docprovide) +(provide #%app #%top (rename-out (DMdA-module-begin #%module-begin)) #%datum #%top-interaction require lib planet + define let let* letrec lambda cond if else begin and or + define-record-procedures define-record-procedures-parametric + .. ... .... ..... ...... + check-expect check-within check-error + : define-contract -> mixed one-of predicate combined property + number real rational integer natural boolean true false string empty-list + chocolate-cookie) +(provide cons list) +(provide-and-document + procedures + (all-from-except beginner: deinprogramm/DMdA procedures + set! define-record-procedures-2 eq? equal? + quote + make-pair pair? first rest + length map for-each reverse append list list-ref fold + symbol? + apply)) diff --git a/collects/deinprogramm/DMdA-beginner/lang/reader.ss b/collects/deinprogramm/DMdA-beginner/lang/reader.ss new file mode 100644 index 0000000000..b5a9b9b839 --- /dev/null +++ b/collects/deinprogramm/DMdA-beginner/lang/reader.ss @@ -0,0 +1,2 @@ +(module reader syntax/module-reader + deinprogramm/DMdA-beginner) diff --git a/collects/deinprogramm/DMdA-reader.ss b/collects/deinprogramm/DMdA-reader.ss new file mode 100644 index 0000000000..186854cac7 --- /dev/null +++ b/collects/deinprogramm/DMdA-reader.ss @@ -0,0 +1,45 @@ +#lang scheme/base + + (require mzlib/etc) + (provide make-read-syntax + make-read) + + (define (make-read spec) + (let ([read + (opt-lambda ([port (current-input-port)]) + (syntax->datum ((make-read-syntax spec) 'whatever port)))]) + read)) + + (define (get-all-exps source-name port) + (let loop () + (let ([exp (read-syntax source-name port)]) + (cond + [(eof-object? exp) null] + [else (cons exp (loop))])))) + + (define (lookup key table) + (let ([ans (assoc key table)]) + (unless ans + (error 'special-reader "couldn't find ~s in table ~s" + key table)) + (cadr ans))) + + (define (make-read-syntax spec) + (let ([read-syntax + (opt-lambda ([source-name #f] + [port (current-input-port)]) + (let* ([table (read port)] + [path (object-name port)] + [modname + (if (path-string? path) + (let-values ([(base name dir) (split-path path)]) + (string->symbol (path->string (path-replace-suffix name #"")))) + (lookup 'modname table))]) + (datum->syntax + #f + `(module ,modname ,spec + ,@(map (lambda (x) `(require ,x)) + (lookup 'teachpacks table)) + ,@(parameterize ([read-case-sensitive (lookup 'read-case-sensitive table)]) + (get-all-exps source-name port))))))]) + read-syntax)) diff --git a/collects/deinprogramm/DMdA-vanilla-reader.ss b/collects/deinprogramm/DMdA-vanilla-reader.ss new file mode 100644 index 0000000000..6c466e37ec --- /dev/null +++ b/collects/deinprogramm/DMdA-vanilla-reader.ss @@ -0,0 +1,7 @@ +(module DMdA-vanilla-reader mzscheme + (require "DMdA-reader.ss") + (provide (rename -read-syntax read-syntax) + (rename -read read)) + (define -read-syntax (make-read-syntax '(lib "DMdA-vanilla.ss" "deinprogramm"))) + (define -read (make-read '(lib "DMdA-vanilla.ss" "deinprogramm")))) + diff --git a/collects/deinprogramm/DMdA-vanilla.ss b/collects/deinprogramm/DMdA-vanilla.ss new file mode 100644 index 0000000000..a4a321338f --- /dev/null +++ b/collects/deinprogramm/DMdA-vanilla.ss @@ -0,0 +1,20 @@ +#lang deinprogramm/DMdA + +(require syntax/docprovide) +(provide #%app #%top (rename-out (DMdA-module-begin #%module-begin)) #%datum #%top-interaction require lib planet + define let let* letrec lambda cond if else begin and or + define-record-procedures define-record-procedures-parametric + .. ... .... ..... ...... + check-expect check-within check-error + : define-contract -> mixed one-of predicate combined property + number real rational integer natural boolean true false string empty-list + chocolate-cookie) +(provide cons) +(provide-and-document + procedures + (all-from-except vanilla: deinprogramm/DMdA procedures + quote eq? equal? + set! + define-record-procedures-2 + symbol? + apply)) diff --git a/collects/deinprogramm/DMdA-vanilla/lang/reader.ss b/collects/deinprogramm/DMdA-vanilla/lang/reader.ss new file mode 100644 index 0000000000..524564321f --- /dev/null +++ b/collects/deinprogramm/DMdA-vanilla/lang/reader.ss @@ -0,0 +1,2 @@ +(module reader syntax/module-reader + deinprogramm/DMdA-vanilla) diff --git a/collects/deinprogramm/DMdA.ss b/collects/deinprogramm/DMdA.ss new file mode 100644 index 0000000000..8ddfa620be --- /dev/null +++ b/collects/deinprogramm/DMdA.ss @@ -0,0 +1,953 @@ +#lang scheme/base + +(require syntax/docprovide) + +(require test-engine/scheme-tests) + +(require deinprogramm/contract/module-begin + deinprogramm/contract/contract-syntax) + +(require (for-syntax scheme/base) + (for-syntax stepper/private/shared)) + +(require deinprogramm/define-record-procedures) + +(require (for-syntax deinprogramm/syntax-checkers)) + +(provide provide lib planet rename-out require #%datum #%module-begin #%top-interaction) ; so we can use this as a language + +(provide cons) ; hack, for the stepper + +(provide (all-from-out deinprogramm/define-record-procedures)) +(provide (all-from-out test-engine/scheme-tests)) +(provide define-contract : + -> mixed one-of predicate combined property) + +(provide number real rational integer natural + boolean true false + string symbol + empty-list + chocolate-cookie + unspecific) + +(define-syntax provide/rename + (syntax-rules () + ((provide/rename (here there) ...) + (begin + (provide (rename-out (here there))) ...)))) + +(provide/rename + (DMdA-define define) + (DMdA-let let) + (DMdA-let* let*) + (DMdA-letrec letrec) + (DMdA-lambda lambda) + (DMdA-cond cond) + (DMdA-if if) + (DMdA-else else) + (DMdA-begin begin) + (DMdA-and and) + (DMdA-or or) + (DMdA-dots ..) + (DMdA-dots ...) + (DMdA-dots ....) + (DMdA-dots .....) + (DMdA-dots ......) + (DMdA-app #%app) + (DMdA-top #%top) + (DMdA-set! set!) + (module-begin DMdA-module-begin)) + +(provide DMdA-advanced-lambda + DMdA-advanced-define) + +(provide quote) + +(provide-and-document + procedures + ("Zahlen" + (number? (%a -> boolean) + "feststellen, ob ein Wert eine Zahl ist") + + (= (number number number ... -> boolean) + "Zahlen auf Gleichheit testen") + (< (real real real ... -> boolean) + "Zahlen auf kleiner-als testen") + (> (real real real ... -> boolean) + "Zahlen auf größer-als testen") + (<= (real real real ... -> boolean) + "Zahlen auf kleiner-gleich testen") + (>= (real real real ... -> boolean) + "Zahlen auf größer-gleich testen") + + (+ (number number number ... -> number) + "Summe berechnen") + (- (number number ... -> number) + "bei mehr als einem Argument Differenz zwischen der ersten und der Summe aller weiteren Argumente berechnen; bei einem Argument Zahl negieren") + (* (number number number ... -> number) + "Produkt berechnen") + (/ (number number number ... -> number) + "das erste Argument durch das Produkt aller weiteren Argumente berechnen") + (max (real real ... -> real) + "Maximum berechnen") + (min (real real ... -> real) + "Minimum berechnen") + (quotient (integer integer -> integer) + "ganzzahlig dividieren") + (remainder (integer integer -> integer) + "Divisionsrest berechnen") + (modulo (integer integer -> integer) + "Divisionsmodulo berechnen") + (sqrt (number -> number) + "Quadratwurzel berechnen") + (expt (number number -> number) + "Potenz berechnen (erstes Argument hoch zweites Argument)") + (abs (real -> real) + "Absolutwert berechnen") + + ;; fancy numeric + (exp (number -> number) + "Exponentialfunktion berechnen (e hoch Argument)") + (log (number -> number) + "natürlichen Logarithmus (Basis e) berechnen") + + ;; trigonometry + (sin (number -> number) + "Sinus berechnen (Argument in Radian)") + (cos (number -> number) + "Cosinus berechnen (Argument in Radian)") + (tan (number -> number) + "Tangens berechnen (Argument in Radian)") + (asin (number -> number) + "Arcussinus berechnen (in Radian)") + (acos (number -> number) + "Arcuscosinus berechnen (in Radian)") + (atan (number -> number) + "Arcustangens berechnen (in Radian)") + + (exact? (number -> boolean) + "feststellen, ob eine Zahl exakt ist") + + (integer? (%a -> boolean) + "feststellen, ob ein Wert eine ganze Zahl ist") + (natural? (%a -> boolean) + "feststellen, ob ein Wert eine natürliche Zahl (inkl. 0) ist") + + (zero? (number -> boolean) + "feststellen, ob eine Zahl Null ist") + (positive? (number -> boolean) + "feststellen, ob eine Zahl positiv ist") + (negative? (number -> boolean) + "feststellen, ob eine Zahl negativ ist") + (odd? (integer -> boolean) + "feststellen, ob eine Zahl ungerade ist") + (even? (integer -> boolean) + "feststellen, ob eine Zahl gerade ist") + + (lcm (natural natural ... -> natural) + "kleinstes gemeinsames Vielfaches berechnen") + + (gcd (natural natural ... -> natural) + "größten gemeinsamen Teiler berechnen") + + (rational? (%a -> boolean) + "feststellen, ob eine Zahl rational ist") + + (numerator (rational -> integer) + "Zähler eines Bruchs berechnen") + + (denominator (rational -> natural) + "Nenner eines Bruchs berechnen") + + (inexact? (number -> boolean) + "feststellen, ob eine Zahl inexakt ist") + + (real? (%a -> boolean) + "feststellen, ob ein Wert eine reelle Zahl ist") + + (floor (real -> integer) + "nächste ganze Zahl unterhalb einer rellen Zahlen berechnen") + + (ceiling (real -> integer) + "nächste ganze Zahl oberhalb einer rellen Zahlen berechnen") + + (round (real -> integer) + "relle Zahl auf eine ganze Zahl runden") + + (complex? (%a -> boolean) + "feststellen, ob ein Wert eine komplexe Zahl ist") + + (make-polar (real real -> number) + "komplexe Zahl aus Abstand zum Ursprung und Winkel berechnen") + + (real-part (number -> real) + "reellen Anteil einer komplexen Zahl extrahieren") + + (imag-part (number -> real) + "imaginären Anteil einer komplexen Zahl extrahieren") + + (magnitude (number -> real) + "Abstand zum Ursprung einer komplexen Zahl berechnen") + + (angle (number -> real) + "Winkel einer komplexen Zahl berechnen") + + (exact->inexact (number -> number) + "eine Zahl durch eine inexakte Zahl annähern") + + (inexact->exact (number -> number) + "eine Zahl durch eine exakte Zahl annähern") + + ;; "Odds and ends" + + (number->string (number -> string) + "Zahl in Zeichenkette umwandeln") + + (string->number (string -> (mixed number (one-of #f))) + "Zeichenkette in Zahl umwandeln, falls möglich") + + (random (natural -> natural) + "eine natürliche Zufallszahl berechnen, die kleiner als das Argument ist") + + (current-seconds (-> natural) + "aktuelle Zeit in Sekunden seit einem unspezifizierten Startzeitpunkt berechnen")) + + ("boolesche Werte" + (boolean? (%a -> boolean) + "feststellen, ob ein Wert ein boolescher Wert ist") + + ((DMdA-not not) (boolean -> boolean) + "booleschen Wert negieren") + + (boolean=? (boolean boolean -> boolean) + "Booleans auf Gleichheit testen") + + (true? (%a -> boolean) + "feststellen, ob ein Wert #t ist") + (false? (%a -> boolean) + "feststellen, ob ein Wert #f ist")) + + ("Listen" + (empty list "die leere Liste") + (make-pair (%a (list %a) -> (list %a)) + "erzeuge ein Paar aus Element und Liste") + (pair? (%a -> boolean) + "feststellen, ob ein Wert ein Paar ist") + (empty? (%a -> boolean) + "feststellen, ob ein Wert die leere Liste ist") + + (first ((list %a) -> %a) + "erstes Element eines Paars extrahieren") + (rest ((list %a) -> (list %a)) + "Rest eines Paars extrahieren") + + (list (%a ... -> (list %a)) + "Liste aus den Argumenten konstruieren") + + (length ((list %a) -> natural) + "Länge einer Liste berechnen") + + (fold ((%b (%a %b -> %b) (list %a) -> %b) + "Liste einfalten.")) + + ((DMdA-append append) ((list %a) ... -> (list %a)) + "mehrere Listen aneinanderhängen") + + (list-ref ((list %a) natural -> %a) + "das Listenelement an der gegebenen Position extrahieren") + + (reverse ((list %a) -> (list %a)) + "Liste in umgekehrte Reihenfolge bringen")) + + ("Schokokekse" + (make-chocolate-cookie (number number -> chocolate-cookie) + "Schokokeks aus Schoko- und Keks-Anteil konstruieren") + (chocolate-cookie? (%a -> boolean) + "feststellen, ob ein Wert ein Schokokeks ist") + (chocolate-cookie-chocolate (chocolate-cookie -> number) + "Schoko-Anteil eines Schokokekses extrahieren") + (chocolate-cookie-cookie (chocolate-cookie -> number) + "Keks-Anteil eines Schokokekses extrahieren")) + + ;; #### Zeichen sollten noch dazu, Vektoren wahrscheinlich auch + + ("Zeichenketten" + (string? (%a -> boolean) + "feststellen, ob ein Wert eine Zeichenkette ist") + + (string=? (string string string ... -> boolean) + "Zeichenketten auf Gleichheit testen") + (string boolean) + "Zeichenketten lexikografisch auf kleiner-als testen") + (string>? (string string string ... -> boolean) + "Zeichenketten lexikografisch auf größer-als testen") + (string<=? (string string string ... -> boolean) + "Zeichenketten lexikografisch auf kleiner-gleich testen") + (string>=? (string string string ... -> boolean) + "Zeichenketten lexikografisch auf größer-gleich testen") + + (string-append (string string ... -> string) + "Hängt Zeichenketten zu einer Zeichenkette zusammen") + + (strings-list->string ((list string) -> string) + "Eine Liste von Zeichenketten in eine Zeichenkette umwandeln") + + (string->strings-list (string -> (list string)) + "Eine Zeichenkette in eine Liste von Zeichenketten mit einzelnen Zeichen umwandeln") + + (string-length (string -> natural) + "Liefert Länge einer Zeichenkette")) + + ("Symbole" + (symbol? (%a -> boolean) + "feststellen, ob ein Wert ein Symbol ist") + (symbol->string (symbol -> string) + "Symbol in Zeichenkette umwandeln")) + + ("Verschiedenes" + (equal? (%a %b -> boolean) + "zwei Werte auf Gleichheit testen") + (eq? (%a %b -> boolean) + "zwei Werte auf Selbheit testen") + ((DMdA-write-string write-string) (string -> unspecific) + "Zeichenkette in REPL ausgeben") + (write-newline (-> unspecific) + "Zeilenumbruch ausgeben") + (violation (string -> unspecific) + "Programmm mit Fehlermeldung abbrechen") + + (map ((%a -> %b) (list %a) -> (list %b)) + "Prozedur auf alle Elemente einer Liste anwenden, Liste der Resultate berechnen") + (for-each ((%a -> %b) (list %a) -> unspecific) + "Prozedur von vorn nach hinten auf alle Elemente einer Liste anwenden") + (apply (procedure (list %a) -> %b) + "Prozedur auf Liste ihrer Argumente anwenden"))) + +(define (make-pair f r) + (when (and (not (null? r)) + (not (pair? r))) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "Zweites Argument zu make-pair ist keine Liste, sondern ~e" r)) + (current-continuation-marks)))) + (cons f r)) + +(define (first l) + (when (not (pair? l)) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "Argument zu first kein Paar, sondern ~e" l)) + (current-continuation-marks)))) + (car l)) + +(define (rest l) + (when (not (pair? l)) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "Argument zu rest kein Paar, sondern ~e" l)) + (current-continuation-marks)))) + (cdr l)) + +(define empty '()) + +(define (empty? obj) + (null? obj)) + +(define (DMdA-append . args) + (let loop ((args args) + (seen-rev '())) + (when (not (null? args)) + (let ((arg (car args))) + (when (and (not (null? arg)) + (not (pair? arg))) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "Argument zu append keine Liste, sondern ~e; restliche Argumente:~a" + arg + (apply string-append + (map (lambda (arg) + (format " ~e" arg)) + (append (reverse seen-rev) + (list '<...>) + (cdr args)))))) + (current-continuation-marks)))) + (loop (cdr args) + (cons arg seen-rev))))) + + (apply append args)) + +(define fold + (lambda (unit combine lis) + (cond + ((empty? lis) unit) + ((pair? lis) + (combine (first lis) + (fold unit combine (rest lis))))))) + +;; This is copied from collects/lang/private/beginner-funs.ss +;; Test-suite support (require is really an effect +;; to make sure that it's loaded) +(require "test-suite.ss") + +(define-for-syntax (binding-in-this-module? b) + (and (list? b) + (module-path-index? (car b)) + (let-values (((path base) (module-path-index-split (car b)))) + (and (not path) (not base))))) + +(define-for-syntax (transform-DMdA-define stx mutable?) + (unless (memq (syntax-local-context) '(module top-level)) + (raise-syntax-error + #f "Define muss ganz außen stehen" stx)) + (syntax-case stx () + ((DMdA-define) + (raise-syntax-error + #f "Definition ohne Operanden" stx)) + ((DMdA-define v) + (raise-syntax-error + #f "Define erwartet zwei Operanden, nicht einen" stx)) + ((DMdA-define var expr) + (begin + (check-for-id! + (syntax var) + "Der erste Operand der Definition ist kein Bezeichner") + + (let ((binding (identifier-binding (syntax var)))) + (when binding + (if (binding-in-this-module? binding) + (raise-syntax-error + #f + "Zweite Definition für denselben Namen" + stx) + (raise-syntax-error + #f + "Dieser Name gehört einer eingebauten Prozedur und kann nicht erneut definiert werden" (syntax var))))) + (if mutable? + (with-syntax + ((dummy-def (stepper-syntax-property + (syntax (define dummy (lambda () (set! var 'dummy)))) + 'stepper-skip-completely + #t))) + (syntax/loc stx + (begin + dummy-def + (define var expr)))) + (syntax/loc stx (define var expr))))) + ((DMdA-define v e1 e2 e3 ...) + (raise-syntax-error + #f "Definition mit mehr als zwei Operanden" stx)))) + +(define-syntax (DMdA-define stx) + (transform-DMdA-define stx #f)) + +(define-syntax (DMdA-advanced-define stx) + (transform-DMdA-define stx #t)) + +(define-syntax (DMdA-let stx) + (syntax-case stx () + ((DMdA-let () body) + (syntax/loc stx body)) + ((DMdA-let ((var expr) ...) body) + (begin + (check-for-id-list! + (syntax->list (syntax (var ...))) + "Kein Bezeichner in Let-Bindung") + (syntax/loc stx ((lambda (var ...) body) expr ...)))) + ((DMdA-let ((var expr) ...) body1 body2 ...) + (raise-syntax-error + #f "Let-Ausdruck hat mehr als einen Ausdruck als Rumpf" stx)) + ((DMdA-let expr ...) + (raise-syntax-error + #f "Let-Ausdruck erwartet eine Liste von Bindungen (Paare aus Name und Ausdruck) und einen Rumpf" stx)))) + +(define-syntax (DMdA-let* stx) + (syntax-case stx () + ((DMdA-let* () body) + (syntax/loc stx body)) + ((DMdA-let* ((var1 expr1) (var2 expr2) ...) body) + (begin + (check-for-id! + (syntax var1) + "Kein Bezeichner in Let*-Bindung") + (syntax/loc stx ((lambda (var1) + (DMdA-let* ((var2 expr2) ...) body)) + expr1)))) + ((DMdA-let* ((var expr) ...) body1 body2 ...) + (raise-syntax-error + #f "Let*-Ausdruck hat mehr als einen Ausdruck als Rumpf" stx)) + ((DMdA-let* expr ...) + (raise-syntax-error + #f "Let*-Ausdruck erwartet eine Liste von Bindungen (Paare aus Name und Ausdruck) und einen Rumpf" stx)))) + +(define-syntax (DMdA-letrec stx) + (syntax-case stx () + ((DMdA-letrec ((var expr) ...) body) + (begin + (check-for-id-list! + (syntax->list (syntax (var ...))) + "Kein Bezeichner in letrec-Bindung") + (syntax/loc stx (letrec ((var expr) ...) body)))) + ((DMdA-letrec ((var expr) ...) body1 body2 ...) + (raise-syntax-error + #f "Letrec hat mehr als einen Ausdruck als Rumpf" stx)))) + +(define-syntax (DMdA-lambda stx) + (syntax-case stx () + ((DMdA-lambda (var ...) body) + (begin + (check-for-id-list! + (syntax->list (syntax (var ...))) + "Kein Bezeichner als Parameter der Lambda-Abstraktion") + (syntax/loc stx (lambda (var ...) body)))) + ((DMdA-lambda (var ...) body1 body2 ...) + (raise-syntax-error + #f "Lambda-Abstraktion hat mehr als einen Ausdruck als Rumpf" stx)) + ((DMdA-lambda var body ...) + (identifier? (syntax var)) + (raise-syntax-error + #f "Um die Parameter einer Lambda-Abstraktion gehören Klammern" (syntax var))) + ((DMdA-lambda var ...) + (raise-syntax-error + #f "Fehlerhafte Lambda-Abstraktion" stx)))) + +(define-syntax (DMdA-advanced-lambda stx) + (syntax-case stx () + ((DMdA-lambda (var ...) body) + (begin + (check-for-id-list! + (syntax->list (syntax (var ...))) + "Kein Bezeichner als Parameter der Lambda-Abstraktion") + (syntax/loc stx (lambda (var ...) body)))) + ((DMdA-lambda (var ... . rest) body) + (begin + (check-for-id-list! + (syntax->list (syntax (var ...))) + "Kein Bezeichner als Parameter der Lambda-Abstraktion") + (check-for-id! + (syntax rest) + "Kein Bezeichner als Restlisten-Parameter der Lambda-Abstraktion") + (syntax/loc stx (lambda (var ... . rest) body)))) + ((DMdA-lambda (var ...) body1 body2 ...) + (raise-syntax-error + #f "Lambda-Abstraktion hat mehr als einen Ausdruck als Rumpf" stx)) + ((DMdA-lambda var ...) + (raise-syntax-error + #f "Fehlerhafte Lambda-Abstraktion" stx)))) + +(define-syntax (DMdA-begin stx) + (syntax-case stx () + ((DMdA-begin) + (raise-syntax-error + #f "Begin-Ausdruck braucht mindestens einen Operanden" stx)) + ((DMdA-begin expr1 expr2 ...) + (syntax/loc stx (begin expr1 expr2 ...))))) + +(define-for-syntax (local-expand-for-error stx ctx stops) + ;; This function should only be called in an 'expression + ;; context. In case we mess up, avoid bogus error messages. + (when (memq (syntax-local-context) '(expression)) + (local-expand stx ctx stops))) + +(define-for-syntax (ensure-expression stx k) + (if (memq (syntax-local-context) '(expression)) + (k) + (stepper-syntax-property #`(begin0 #,stx) 'stepper-skipto skipto/second))) + +;; A consistent pattern for stepper-skipto: +(define-for-syntax (stepper-ignore-checker stx) + (stepper-syntax-property stx 'stepper-skipto '(syntax-e cdr syntax-e cdr car))) + +;; Raise a syntax error: +(define-for-syntax (teach-syntax-error form stx detail msg . args) + (let ([form (if (eq? form '|function call|) ; #### + form + #f)] ; extract name from stx + [msg (apply format msg args)]) + (if detail + (raise-syntax-error form msg stx detail) + (raise-syntax-error form msg stx)))) + +;; The syntax error when a form's name doesn't follow a "(" +(define-for-syntax (bad-use-error name stx) + (teach-syntax-error + name + stx + #f + "`~a' wurde an einer Stelle gefunden, die keiner offenen Klammer folgt" + name)) + +;; Use for messages "expected ..., found " +(define-for-syntax (something-else v) + (let ([v (syntax-e v)]) + (cond + [(number? v) "eine Zahl"] + [(string? v) "eine Zeichenkette"] + [else "etwas anderes"]))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; cond +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax (DMdA-cond stx) + (ensure-expression + stx + (lambda () + (syntax-case stx () + [(_) + (teach-syntax-error + 'cond + stx + #f + "Frage und eine Antwort nach `cond' erwartet, aber da ist nichts")] + [(_ clause ...) + (let* ([clauses (syntax->list (syntax (clause ...)))] + [check-preceding-exprs + (lambda (stop-before) + (let/ec k + (for-each (lambda (clause) + (if (eq? clause stop-before) + (k #t) + (syntax-case clause () + [(question answer) + (begin + (unless (and (identifier? (syntax question)) + (free-identifier=? (syntax question) #'DMdA-else)) + (local-expand-for-error (syntax question) 'expression null)) + (local-expand-for-error (syntax answer) 'expression null))]))) + clauses)))]) + (let ([checked-clauses + (map + (lambda (clause) + (syntax-case clause (DMdA-else) + [(DMdA-else answer) + (let ([lpos (memq clause clauses)]) + (when (not (null? (cdr lpos))) + (teach-syntax-error + 'cond + stx + clause + "`else'-Test gefunden, der nicht am Ende des `cond'-Ausdrucks steht")) + (with-syntax ([new-test (stepper-syntax-property (syntax #t) 'stepper-else #t)]) + (syntax/loc clause (new-test answer))))] + [(question answer) + (with-syntax ([verified (stepper-ignore-checker (syntax (verify-boolean question 'cond)))]) + (syntax/loc clause (verified answer)))] + [() + (check-preceding-exprs clause) + (teach-syntax-error + 'cond + stx + clause + "Test und Ausdruck in Zweig erwartet, aber Zweig leer")] + [(question?) + (check-preceding-exprs clause) + (teach-syntax-error + 'cond + stx + clause + "Zweig mit Test und Ausdruck erwartet, aber Zweig enthält nur eine Form")] + [(question? answer? ...) + (check-preceding-exprs clause) + (let ([parts (syntax->list clause)]) + ;; to ensure the illusion of left-to-right checking, make sure + ;; the question and first answer (if any) are ok: + (unless (and (identifier? (car parts)) + (free-identifier=? (car parts) #'DMdA-else)) + (local-expand-for-error (car parts) 'expression null)) + (unless (null? (cdr parts)) + (local-expand-for-error (cadr parts) 'expression null)) + ;; question and answer (if any) are ok, raise a count-based exception: + (teach-syntax-error + 'cond + stx + clause + "Zweig mit Test und Ausdruck erwartet, aber Zweig enthält ~a Formen" + (length parts)))] + [_else + (teach-syntax-error + 'cond + stx + clause + "Zweig mit Test und Ausdruck erwartet, aber ~a gefunden" + (something-else clause))])) + clauses)]) + ;; Add `else' clause for error (always): + (let ([clauses (append checked-clauses + (list + (with-syntax ([error-call (syntax/loc stx (error 'cond "alle Tests ergaben #f"))]) + (syntax [else error-call]))))]) + (with-syntax ([clauses clauses]) + (syntax/loc stx (cond . clauses))))))] + [_else (bad-use-error 'cond stx)])))) + +(define-syntax DMdA-else + (make-set!-transformer + (lambda (stx) + (define (bad expr) + (teach-syntax-error + 'else + expr + #f + "hier nicht erlaubt, weil kein Test in `cond'-Zweig")) + (syntax-case stx (set! x) + [(set! e expr) (bad #'e)] + [(e . expr) (bad #'e)] + [e (bad stx)])))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; if +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax (DMdA-if stx) + (ensure-expression + stx + (lambda () + (syntax-case stx () + [(_ test then else) + (with-syntax ([new-test (stepper-ignore-checker (syntax (verify-boolean test 'if)))]) + (syntax/loc stx + (if new-test + then + else)))] + [(_ . rest) + (let ([n (length (syntax->list (syntax rest)))]) + (teach-syntax-error + 'if + stx + #f + "Test und zwei Ausdrücke erwartet, aber ~a Form~a gefunden" + (if (zero? n) "keine" n) + (if (= n 1) "" "en")))] + [_else (bad-use-error 'if stx)])))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; or, and +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntaxes (DMdA-or DMdA-and) + (let ([mk + (lambda (where) + (let ([stepper-tag (case where + [(or) 'comes-from-or] + [(and) 'comes-from-and])]) + (with-syntax ([swhere where]) + (lambda (stx) + (ensure-expression + stx + (lambda () + (syntax-case stx () + [(_ . clauses) + (let ([n (length (syntax->list (syntax clauses)))]) + (let loop ([clauses-consumed 0] + [remaining (syntax->list #`clauses)]) + (if (null? remaining) + (case where + [(or) #`#f] + [(and) #`#t]) + (stepper-syntax-property + (stepper-syntax-property + (quasisyntax/loc + stx + (if #,(stepper-ignore-checker (quasisyntax/loc stx (verify-boolean #,(car remaining) 'swhere))) + #,@(case where + [(or) #`(#t + #,(loop (+ clauses-consumed 1) (cdr remaining)))] + [(and) #`(#,(loop (+ clauses-consumed 1) (cdr remaining)) + #f)]))) + 'stepper-hint + stepper-tag) + 'stepper-and/or-clauses-consumed + clauses-consumed))))] + [_else (bad-use-error where stx)])))))))]) + (values (mk 'or) (mk 'and)))) + +;; verify-boolean is inserted to check for boolean results: +(define (verify-boolean b where) + (if (or (eq? b #t) (eq? b #f)) + b + (raise + (make-exn:fail:contract + (string->immutable-string + (format "~a: Testresultat ist nicht boolesch: ~e" where b)) + (current-continuation-marks))))) + +(define (DMdA-not b) + (verify-boolean b 'not) + (not b)) + +(define (boolean=? a b) + (verify-boolean a 'boolean=?) + (verify-boolean b 'boolean=?) + (eq? a b)) + +(define-syntax (DMdA-app stx) + (syntax-case stx () + ((_) + (raise-syntax-error + #f "Zusammengesetzte Form ohne Operator" (syntax/loc stx ()))) + ((_ datum1 datum2 ...) + (let ((scm-datum (syntax->datum (syntax datum1)))) + (or (number? scm-datum) + (boolean? scm-datum) + (string? scm-datum) + (char? scm-datum))) + (raise-syntax-error #f "Operator darf kein Literal sein" (syntax datum1))) + ((_ datum1 datum2 ...) + (syntax/loc stx (#%app datum1 datum2 ...))))) + +(define-syntax (DMdA-top stx) + (syntax-case stx () + ((_ . id) + ;; If we're in a module, we'll need to check that the name + ;; is bound.... + (if (and (not (identifier-binding #'id)) + (syntax-source-module #'id)) + ;; ... but it might be defined later in the module, so + ;; delay the check. + (stepper-ignore-checker + (syntax/loc stx (#%app values (DMdA-top-continue id)))) + (syntax/loc stx (#%top . id)))))) + +(define-syntax (DMdA-top-continue stx) + (syntax-case stx () + [(_ id) + ;; If there's still no binding, it's an "unknown name" error. + (if (not (identifier-binding #'id)) + (raise-syntax-error #f "Ungebundene Variable" (syntax/loc stx id)) + ;; Don't use #%top here; id might have become bound to something + ;; that isn't a value. + #'id)])) + +(define (DMdA-write-string s) + (when (not (string? s)) + (error "Argument von write-string ist keine Zeichenkette")) + (display s)) + +(define (write-newline) + (newline)) + +(define-record-procedures chocolate-cookie + make-chocolate-cookie chocolate-cookie? + (chocolate-cookie-chocolate chocolate-cookie-cookie)) + +(define (violation text) + (error text)) + +(define (string->strings-list s) + (map (lambda (c) (make-string 1 c)) (string->list s))) + +(define (strings-list->string l) + (if (null? l) + "" + (string-append (car l) (strings-list->string (cdr l))))) + +(define-contract integer (predicate integer?)) +(define-contract number (predicate number?)) +(define-contract rational (predicate rational?)) +(define-contract real (predicate real?)) + +(define (natural? x) + (and (integer? x) + (not (negative? x)))) + +(define-contract natural (predicate natural?)) + +(define-contract boolean (predicate boolean?)) + +(define (true? x) + (eq? x #t)) + +(define (false? x) + (eq? x #f)) + +(define-contract true (predicate true?)) +(define-contract false (predicate false?)) + +(define-contract string (predicate string?)) +(define-contract symbol (predicate symbol?)) +(define-contract empty-list (predicate empty?)) + +(define-contract unspecific (predicate (lambda (_) #t))) + +;; aus collects/lang/private/teach.ss + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dots (.. and ... and .... and ..... and ......) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Syntax Identifier -> Expression +;; Produces an expression which raises an error reporting unfinished code. +(define-for-syntax (dots-error stx name) + (quasisyntax/loc stx + (error (quote (unsyntax name)) + "Fertiger Ausdruck erwartet, aber da sind noch Ellipsen"))) + +;; Expression -> Expression +;; Transforms unfinished code (... and the like) to code +;; raising an appropriate error. +(define-syntax DMdA-dots + (make-set!-transformer + (lambda (stx) + (syntax-case stx (set!) + [(set! form expr) (dots-error stx (syntax form))] + [(form . rest) (dots-error stx (syntax form))] + [form (dots-error stx stx)])))) + +(define-syntaxes (DMdA-set! DMdA-set!-continue) + (let ((proc + (lambda (continuing?) + (lambda (stx) + (ensure-expression + stx + (lambda () + (syntax-case stx () + ((_ id expr) + (identifier? (syntax id)) + (begin + ;; Check that id isn't syntax, and not lexical. + ((with-handlers ((exn:fail? (lambda (exn) void))) + ;; First try syntax: + ;; If it's a transformer binding, then it can take care of itself... + (if (set!-transformer? (syntax-local-value (syntax id))) + void ;; no lex check wanted + (lambda () + (raise-syntax-error + #f + "Nach set! wird eine gebundene Variable erwartet, aber da ist ein Schlüsselwort." + stx))))) + ;; If we're in a module, we'd like to check here whether + ;; the identier is bound, but we need to delay that check + ;; in case the id is defined later in the module. So only + ;; do this in continuing mode: + (when continuing? + (when (and (not (identifier-binding #'id)) + (syntax-source-module #'id)) + (raise-syntax-error #f "Ungebundene Variable" #'id))) + (if continuing? + (syntax/loc stx (set! id expr)) + (stepper-ignore-checker (syntax/loc stx (#%app values (DMdA-set!-continue id expr))))))) + ((_ id expr) + (raise-syntax-error + #f + "Nach set! wird eine Variable aber da ist etwas anderes." + #'id)) + ((_ id) + (raise-syntax-error + #f + "Nach set! wird eine Variable und ein Ausdruck erwartet - der Ausdruck fehlt." + stx)) + ((_) + (raise-syntax-error + #f + "Nach set! wird eine Variable und ein Ausdruck erwartet, aber da ist nichts." + stx)) + (_else + (raise-syntax-error + #f + "Inkorrekter set!-Ausdruck." + stx))))))))) + (values (proc #f) + (proc #t)))) diff --git a/collects/deinprogramm/DMdA/lang/reader.ss b/collects/deinprogramm/DMdA/lang/reader.ss new file mode 100644 index 0000000000..25a4d2e573 --- /dev/null +++ b/collects/deinprogramm/DMdA/lang/reader.ss @@ -0,0 +1,2 @@ +(module reader syntax/module-reader + deinprogramm/DMdA) diff --git a/collects/deinprogramm/contract/contract-syntax.ss b/collects/deinprogramm/contract/contract-syntax.ss new file mode 100644 index 0000000000..8a6eed6098 --- /dev/null +++ b/collects/deinprogramm/contract/contract-syntax.ss @@ -0,0 +1,214 @@ +#lang scheme/base + +(provide : + contract + define-contract + define/contract define-values/contract + -> mixed one-of predicate combined property) + +(require deinprogramm/contract/contract + scheme/promise + (for-syntax scheme/base) + (for-syntax syntax/stx) + (for-syntax stepper/private/shared)) + +(define-for-syntax (phase-lift stx) + (with-syntax ((?stx stx)) + (with-syntax ((?stx1 (syntax/loc stx #'?stx))) ; attach the occurrence position to the syntax object + #'?stx1))) + +(define-for-syntax (parse-contract name stx) + (syntax-case* stx (mixed one-of predicate list -> combined property reference at) module-or-top-identifier=? + ((mixed ?contract ...) + (with-syntax ((?stx (phase-lift stx)) + (?name name) + ((?contract-expr ...) (map (lambda (ctr) + (parse-contract #f ctr)) + (syntax->list #'(?contract ...))))) + #'(make-mixed-contract '?name + (list ?contract-expr ...) + ?stx))) + ((one-of ?exp ...) + (with-syntax ((?stx (phase-lift stx)) + (?name name)) + #'(make-case-contract '?name (list ?exp ...) ?stx))) + ((predicate ?exp) + (with-syntax ((?stx (phase-lift stx)) + (?name name)) + #'(make-predicate-contract '?name (delay ?exp) ?stx))) + ((list ?contract) + (with-syntax ((?stx (phase-lift stx)) + (?name name) + (?contract-expr (parse-contract #f #'?contract))) + #'(make-list-contract '?name ?contract-expr ?stx))) + ((list ?contract1 ?rest ...) + (raise-syntax-error #f + "list-Vertrag darf nur einen Operanden haben." + (syntax ?contract1))) + ((?arg-contract ... -> ?return-contract) + (with-syntax ((?stx (phase-lift stx)) + (?name name) + ((?arg-contract-exprs ...) (map (lambda (ctr) + (parse-contract #f ctr)) + (syntax->list #'(?arg-contract ...)))) + (?return-contract-expr (parse-contract #f #'?return-contract))) + #'(make-procedure-contract '?name (list ?arg-contract-exprs ...) ?return-contract-expr ?stx))) + ((?arg-contract ... -> ?return-contract1 ?return-contract2 . ?_) + (raise-syntax-error #f + "Nach dem -> darf nur ein Vertrag stehen." + (syntax ?return-contract2))) + ((at ?loc ?ctr) + (with-syntax ((?ctr-expr (parse-contract #f #'?ctr))) + #'(contract-update-syntax ?ctr-expr #'?loc))) + (?id + (identifier? #'?id) + (with-syntax ((?stx (phase-lift stx))) + (let ((name (symbol->string (syntax->datum #'?id)))) + (if (char=? #\% (string-ref name 0)) + #'(make-type-variable-contract '?id ?stx) + (with-syntax + ((?raise + (syntax/loc #'?stx + (error 'contracts "expected a contract, found ~e" ?id)))) + #'(make-delayed-contract '?name + (delay + (begin + (when (not (contract? ?id)) + ?raise) + (contract-update-syntax ?id ?stx))) + #'?stx)))))) + ((combined ?contract ...) + (with-syntax ((?stx (phase-lift stx)) + (?name name) + ((?contract-expr ...) (map (lambda (ctr) + (parse-contract #f ctr)) + (syntax->list #'(?contract ...))))) + #'(make-combined-contract '?name + (list ?contract-expr ...) + ?stx))) + ((property ?access ?contract) + (with-syntax ((?stx (phase-lift stx)) + (?name name) + (?contract-expr (parse-contract #f #'?contract))) + #'(make-property-contract '?name + ?access + ?contract-expr + ?stx))) + ((?contract-abstr ?contract ...) + (identifier? #'?contract-abstr) + (with-syntax (((?contract-expr ...) (map (lambda (ctr) + (parse-contract #f ctr)) + (syntax->list #'(?contract ...))))) + (with-syntax + ((?call (syntax/loc stx (?contract-abstr ?contract-expr ...)))) + #'(make-delayed-contract '?name + (delay ?call) + #'?stx)))) + (else + (raise-syntax-error 'contract + "ungültiger Vertrag" stx)))) + +(define-syntax contract + (lambda (stx) + (syntax-case stx () + ((_ ?contr) + #'(contract #f ?contr)) + ((_ ?name ?contr) + (parse-contract (syntax->datum #'?name) #'?contr))))) + +(define-syntax define-contract + (lambda (stx) + (syntax-case stx () + ((_ ?name ?ctr) + (identifier? #'?name) + (stepper-syntax-property #'(define ?name (contract ?name ?ctr)) + 'stepper-skip-completely + #t)) + ((_ (?name ?param ...) ?ctr) + (and (identifier? #'?name) + (andmap identifier? (syntax->list #'(?param ...)))) + (stepper-syntax-property #'(define (?name ?param ...) (contract ?name ?ctr)) + 'stepper-skip-completely + #t))))) + +(define-syntax define/contract + (lambda (stx) + (syntax-case stx () + ((_ ?name ?cnt ?expr) + (with-syntax ((?enforced + (stepper-syntax-property #'(attach-name '?name (apply-contract/blame (contract ?cnt) ?expr)) + 'stepper-skipto/discard + ;; apply-contract/blame takes care of itself + ;; remember there's an implicit #%app + '(syntax-e cdr syntax-e cdr cdr car)))) + + #'(define ?name ?enforced)))))) + +(define-syntax define-values/contract + (lambda (stx) + (syntax-case stx () + ((_ (?id ...) ?expr) + (andmap identifier? (syntax->list #'(?id ...))) + (syntax-track-origin + #'(define-values (?id ...) ?expr) + stx + (car (syntax-e stx)))) + ((_ ((?id ?cnt)) ?expr) + (identifier? #'?id) + #'(define/contract ?id ?cnt ?expr)) ; works with stepper + ((_ (?bind ...) ?expr) + (let ((ids+enforced + (map (lambda (bind) + (syntax-case bind () + (?id + (identifier? #'?id) + (cons #'?id #'?id)) + ((?id ?cnt) + (identifier? #'?id) + (cons #'?id + #'(attach-name '?id (apply-contract/blame (contract ?cnt) ?id)))))) + (syntax->list #'(?bind ...))))) + (with-syntax (((?id ...) (map car ids+enforced)) + ((?enforced ...) (map cdr ids+enforced))) + (stepper-syntax-property + #'(define-values (?id ...) + (call-with-values + (lambda () ?expr) + (lambda (?id ...) + (values ?enforced ...)))) + 'stepper-skip-completely #t))))))) + +;; Matthew has promised a better way of doing this in the future. +(define (attach-name name thing) + (if (procedure? thing) + (procedure-rename thing name) + thing)) + +(define-syntax : + (syntax-rules () + ((: ?id ?ctr) (begin)))) ; probably never used, we're only interested in the binding for : + +(define-for-syntax (within-contract-syntax-error stx name) + (raise-syntax-error #f + "darf nur in Verträgen vorkommen" + name)) + +;; Expression -> Expression +;; Transforms unfinished code (... and the like) to code +;; raising an appropriate error. +(define-for-syntax within-contract-syntax-transformer + (make-set!-transformer + (lambda (stx) + (syntax-case stx (set!) + [(set! form expr) (within-contract-syntax-error stx (syntax form))] + [(form . rest) (within-contract-syntax-error stx (syntax form))] + [form (within-contract-syntax-error stx stx)])))) + +(define-syntax -> within-contract-syntax-transformer) +(define-syntax mixed within-contract-syntax-transformer) +(define-syntax one-of within-contract-syntax-transformer) +(define-syntax predicate within-contract-syntax-transformer) +(define-syntax combined within-contract-syntax-transformer) +(define-syntax property within-contract-syntax-transformer) +; not a good idea: +; (define-syntax list within-contract-syntax-transformer) diff --git a/collects/deinprogramm/contract/contract-test-display.ss b/collects/deinprogramm/contract/contract-test-display.ss new file mode 100644 index 0000000000..ab2907edf2 --- /dev/null +++ b/collects/deinprogramm/contract/contract-test-display.ss @@ -0,0 +1,388 @@ +#lang scheme/base + +; DeinProgramm version of collects/test-engine/test-display.ss +; synched with SVN rev 11385 + +(provide contract-test-display%) + +(require scheme/class + scheme/file + mred + framework + string-constants + (lib "test-engine/test-info.scm") + (lib "test-engine/test-engine.scm") + deinprogramm/contract/contract + deinprogramm/contract/contract-test-engine) + +(define contract-test-display% + (class* object% () + + (init-field (current-rep #f)) + + (define test-info #f) + (define/pubment (install-info t) + (set! test-info t) + (inner (void) install-info t)) + + (define current-tab #f) + (define drscheme-frame #f) + (define src-editor #f) + (define/public (display-settings df ct ed) + (set! current-tab ct) + (set! drscheme-frame df) + (set! src-editor ed)) + + (define (docked?) + (and drscheme-frame + (get-preference 'test:test-window:docked? + (lambda () (put-preferences '(test:test-window:docked?) '(#f)) #f)))) + + (define/public (report-success) + (when current-rep + (unless current-tab + (set! current-tab (send (send current-rep get-definitions-text) get-tab))) + (unless drscheme-frame + (set! drscheme-frame (send current-rep get-top-level-window))) + (let ([curr-win (and current-tab (send current-tab get-test-window))]) + (when curr-win + (let ([content (make-object (editor:standard-style-list-mixin text%))]) + (send content lock #t) + (when curr-win (send curr-win update-editor content)) + (when current-tab (send current-tab current-test-editor content)) + (when (docked?) + (send drscheme-frame display-test-panel content) + (send curr-win show #f))))))) + + (define/public (display-results) + (let* ([curr-win (and current-tab (send current-tab get-test-window))] + [window (or curr-win (make-object test-window%))] + [content (make-object (editor:standard-style-list-mixin text%))]) + + (send this insert-test-results content test-info src-editor) + (send content lock #t) + (send window update-editor content) + (when current-tab + (send current-tab current-test-editor content) + (unless curr-win + (send current-tab current-test-window window) + (send drscheme-frame register-test-window window) + (send window update-switch + (lambda () (send drscheme-frame dock-tests))) + (send window update-disable + (lambda () (send current-tab update-test-preference #f))) + (send window update-closer + (lambda() + (send drscheme-frame deregister-test-window window) + (send current-tab current-test-window #f) + (send current-tab current-test-editor #f))))) + (if (docked?) + (send drscheme-frame display-test-panel content) + (send window show #t)))) + + (define/pubment (insert-test-results editor test-info src-editor) + (let* ([style (send test-info test-style)] + [total-checks (send test-info checks-run)] + [failed-checks (send test-info checks-failed)] + [violated-contracts (send test-info failed-contracts)] + [check-outcomes + (lambda (zero-message) + (send editor insert + (cond + [(zero? total-checks) zero-message] + [(= 1 total-checks) "Ran 1 check.\n"] + [else (format "Ran ~a checks.\n" total-checks)])) + (when (> total-checks 0) + (send editor insert + (cond + [(and (zero? failed-checks) (= 1 total-checks)) + "Check passed!\n\n"] + [(zero? failed-checks) "All checks passed!\n\n"] + [(= failed-checks total-checks) "0 checks passed.\n"] + [else (format "~a of the ~a checks failed.\n\n" + failed-checks total-checks)]))) + (send editor insert + (cond + ((null? violated-contracts) + "No contract violations!\n\n") + (else + (format "~a contract violations.\n\n" + (length violated-contracts))))) + )]) + (case style + [(check-require) + (check-outcomes "This program is unchecked!\n")] + [else (check-outcomes "")]) + + (unless (and (zero? total-checks) + (null? violated-contracts)) + (inner (begin + (display-check-failures (send test-info failed-checks) + editor test-info src-editor) + (send editor insert "\n") + (display-contract-violations violated-contracts + editor test-info src-editor)) + insert-test-results editor test-info src-editor)))) + + (define/public (display-check-failures checks editor test-info src-editor) + (when (pair? checks) + (send editor insert "Check failures:\n")) + (for ([failed-check (reverse checks)]) + (send editor insert "\t") + (if (failed-check-exn? failed-check) + (make-error-link editor + (failed-check-msg failed-check) + (failed-check-exn? failed-check) + (failed-check-src failed-check) + src-editor) + (make-link editor + (failed-check-msg failed-check) + (failed-check-src failed-check) + src-editor)) + (send editor insert "\n"))) + + (define/public (display-contract-violations violations editor test-info src-editor) + (when (pair? violations) + (send editor insert "Contract violations:\n")) + (for-each (lambda (violation) + (send editor insert "\t") + (make-contract-link editor violation src-editor) + (send editor insert "\n")) + violations)) + + ;next-line: editor% -> void + ;Inserts a newline and a tab into editor + (define/public (next-line editor) (send editor insert "\n\t")) + + ;; make-link: text% (listof (U string snip%)) src editor -> void + (define (make-link text msg dest src-editor) + (insert-messages text msg) + (let ((start (send text get-end-position))) + (send text insert (format-src dest)) + (when (and src-editor current-rep) + (send text set-clickback + start (send text get-end-position) + (lambda (t s e) (highlight-check-error dest src-editor)) + #f #f) + (set-clickback-style text start "royalblue")))) + + ;; make-error-link: text% (listof (U string snip%)) exn src editor -> void + (define (make-error-link text msg exn dest src-editor) + (make-link text msg dest src-editor) + (let ((start (send text get-end-position))) + (send text insert "Trace error ") + (when (and src-editor current-rep) + (send text set-clickback + start (send text get-end-position) + (lambda (t s e) ((error-handler) exn)) + #f #f) + (set-clickback-style text start "red")))) + + (define (insert-messages text msgs) + (for ([m msgs]) + (when (is-a? m snip%) + (send m set-style (send (send text get-style-list) + find-named-style "Standard"))) + (send text insert m))) + + (define (make-contract-link text violation src-editor) + (let* ((contract (contract-violation-contract violation)) + (stx (contract-syntax contract)) + (srcloc (contract-violation-srcloc violation))) + (insert-messages text (contract-violation-messages violation)) + (when srcloc + (send text insert " ") + (let ((source (srcloc-source srcloc)) + (line (srcloc-line srcloc)) + (column (srcloc-column srcloc)) + (pos (srcloc-position srcloc)) + (span (srcloc-span srcloc)) + (start (send text get-end-position))) + (send text insert (format-position source line column)) + (send text set-clickback + start (send text get-end-position) + (lambda (t s e) + (highlight-error line column pos span src-editor)) + #f #f) + (set-clickback-style text start "blue"))) + (send text insert ", contract ") + (format-clickable-syntax-src text stx src-editor) + (cond + ((contract-violation-blame violation) + => (lambda (blame) + (next-line text) + (send text insert "to blame: procedure ") + (format-clickable-syntax-src text blame src-editor)))))) + + (define (format-clickable-syntax-src text stx src-editor) + (let ((start (send text get-end-position))) + (send text insert (format-syntax-src stx)) + (send text set-clickback + start (send text get-end-position) + (lambda (t s e) + (highlight-error/syntax stx src-editor)) + #f #f) + (set-clickback-style text start "blue"))) + + (define (set-clickback-style text start color) + (let ([end (send text get-end-position)] + [c (new style-delta%)]) + (send text insert " ") + (send text change-style + (make-object style-delta% 'change-underline #t) + start end #f) + (send c set-delta-foreground color) + (send text change-style c start end #f))) + + (define (format-syntax-src stx) + (format-position (syntax-source stx) + (syntax-line stx) (syntax-column stx))) + + ;format-src: src -> string + (define (format-src src) + (format-position (car src) (cadr src) (caddr src))) + + (define (format-position file line column) + (string-append + (if (path? file) + (let-values (((base name must-be-dir?) + (split-path file))) + (if (path? name) + (string-append " in " (path->string name) " at ") + "")) + "") + "at line " (cond [line => number->string] + [else "(unknown)"]) + " column " (cond [column => number->string] + [else "(unknown)"]))) + + (define (highlight-error line column position span src-editor) + (when (and current-rep src-editor) + (cond + [(is-a? src-editor text:basic<%>) + (let ((highlight + (lambda () + (send current-rep highlight-errors + (list (make-srcloc src-editor + line + column + position span)) #f)))) + (queue-callback highlight))]))) + + (define (highlight-check-error srcloc src-editor) + (let* ([src-pos cadddr] + [src-span (lambda (l) (car (cddddr l)))] + [position (src-pos srcloc)] + [span (src-span srcloc)]) + (highlight-error (cadr srcloc) (caddr srcloc) + position span + src-editor))) + + (define (highlight-error/syntax stx src-editor) + (highlight-error (syntax-line stx) (syntax-column stx) + (syntax-position stx) (syntax-span stx) + src-editor)) + + (super-instantiate ()))) + +(define test-window% + (class* frame% () + + (super-instantiate + ((string-constant test-engine-window-title) #f 400 350)) + + ;; (define editor #f) + (define switch-func void) + (define disable-func void) + (define close-cleanup void) + + (define content + (make-object editor-canvas% this #f '(auto-vscroll))) + + (define button-panel + (make-object horizontal-panel% this + '() #t 0 0 0 0 '(right bottom) 0 0 #t #f)) + + (define buttons + (list (make-object button% + (string-constant close) + button-panel + (lambda (b c) + (when (eq? 'button (send c get-event-type)) + (close-cleanup) + (send this show #f)))) + (make-object button% + (string-constant dock) + button-panel + (lambda (b c) + (when (eq? 'button (send c get-event-type)) + (send this show #f) + (put-preferences '(test:test-window:docked?) + '(#t)) + (switch-func)))) + (make-object grow-box-spacer-pane% button-panel))) + + (define/public (update-editor e) + ;;(set! editor e) + (send content set-editor e)) + + (define/public (update-switch thunk) + (set! switch-func thunk)) + (define/public (update-closer thunk) + (set! close-cleanup thunk)) + (define/public (update-disable thunk) + (set! disable-func thunk)))) + +(define test-panel% + (class* vertical-panel% () + + (inherit get-parent) + + (super-instantiate ()) + + (define content (make-object editor-canvas% this #f '())) + (define button-panel (make-object horizontal-panel% this + '() #t 0 0 0 0 '(right bottom) 0 0 #t #f)) + (define (hide) + (let ([current-tab (send frame get-current-tab)]) + (send frame deregister-test-window + (send current-tab get-test-window)) + (send current-tab current-test-window #f) + (send current-tab current-test-editor #f)) + (remove)) + + (make-object button% + (string-constant hide) + button-panel + (lambda (b c) + (when (eq? 'button (send c get-event-type)) + (hide)))) + #;(make-object button% + (string-constant profj-test-results-hide-and-disable) + button-panel + (lambda (b c) + (when (eq? 'button (send c get-event-type)) + (hide) + (send (send frame get-current-tab) + update-test-preference #f)))) + (make-object button% + (string-constant undock) + button-panel + (lambda (b c) + (when (eq? 'button (send c get-event-type)) + (put-preferences '(test:test-window:docked?) '(#f)) + (send frame undock-tests)))) + + (define/public (update-editor e) + (send content set-editor e)) + + (define frame #f) + (define/public (update-frame f) + (set! frame f)) + + (define/public (remove) + (let ([parent (get-parent)]) + (put-preferences '(test:test-dock-size) + (list (send parent get-percentages))) + (send parent delete-child this))))) + diff --git a/collects/deinprogramm/contract/contract-test-engine.ss b/collects/deinprogramm/contract/contract-test-engine.ss new file mode 100644 index 0000000000..e62a6fdb15 --- /dev/null +++ b/collects/deinprogramm/contract/contract-test-engine.ss @@ -0,0 +1,138 @@ +#lang scheme/base + +(provide build-contract-test-engine + contract-violation? + contract-violation-obj contract-violation-contract contract-violation-messages + contract-violation-blame contract-violation-srcloc) + +(require scheme/class + (lib "test-engine/test-engine.scm") + (lib "test-engine/test-info.scm")) + +(define (build-contract-test-engine) + (let ((engine (make-object contract-test-engine%))) + (send engine setup-info 'check-require) + engine)) + +(define contract-test-engine% + (class* test-engine% () + (super-instantiate ()) + (inherit-field test-info test-display) + (inherit setup-info display-untested) + + (define display-rep #f) + (define display-event-space #f) + + (field (tests null) + (test-objs null)) + + (define/override (info-class) contract-test-info%) + + ;; need display-rep & display-event-space + (define/augment (setup-display cur-rep event-space) + (set! display-rep cur-rep) + (set! display-event-space event-space) + (inner (void) setup-display cur-rep event-space)) + + (define/public (add-test tst) + (set! tests (cons tst tests))) + (define/public (get-info) + (unless test-info (setup-info 'check-require)) + test-info) + + (define/augment (run) + (inner (void) run) + (for ((t (reverse tests))) (run-test t))) + + (define/augment (run-test test) + (test) + (inner (void) run-test test)) + + (define/private (clear-results event-space) + (when event-space + (parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event-space]) + ((dynamic-require 'scheme/gui 'queue-callback) + (lambda () (send test-display report-success)))))) + + (define/override (summarize-results port) + (cond + ((test-execute) + (unless test-display (setup-display #f #f)) + (send test-display install-info test-info) + (if (pair? (send test-info failed-contracts)) + (send this display-results display-rep display-event-space) + (let ((result (send test-info summarize-results))) + (case result + [(no-tests) + (clear-results display-event-space) + (display-untested port)] + [(all-passed) (display-success port display-event-space + (+ (send test-info tests-run) + (send test-info checks-run)))] + [(mixed-results) + (display-results display-rep display-event-space)])))) + (else + (fprintf port "Tests disabled.\n")))) + + (define/private (display-success port event-space count) + (clear-results event-space) + (unless (test-silence) + (fprintf port "~a test~a passed!\n" + (case count + [(0) "Zero"] + [(1) "The only"] + [(2) "Both"] + [else (format "All ~a" count)]) + (if (= count 1) "" "s")))) + + (define/override (display-results rep event-space) + (cond + [(and rep event-space) + (parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event-space]) + ((dynamic-require 'scheme/gui 'queue-callback) + (lambda () (send rep display-test-results test-display))))] + [event-space + (parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event-space]) + ((dynamic-require 'scheme/gui 'queue-callback) (lambda () (send test-display display-results))))] + [else (send test-display display-results)])) + +)) + +(define-struct contract-violation (obj contract messages srcloc blame)) + +(define contract-test-info% + (class* test-info-base% () + + (define contract-violations '()) + + (define/pubment (contract-failed obj contract message blame) + + (let* ((cms + (continuation-mark-set->list (current-continuation-marks) + ;; set from deinprogramm-langs.ss + 'deinprogramm-teaching-languages-continuation-mark-key)) + (srcloc + (cond + ((findf (lambda (mark) + (and mark + (or (path? (car mark)) + (symbol? (car mark))))) + cms) + => (lambda (mark) + (apply (lambda (source line col pos span) + (make-srcloc source line col pos span)) + mark))) + (else #f))) + (messages + (if message + (list message) + (list "got " ((test-format) obj))))) + + (set! contract-violations + (cons (make-contract-violation obj contract messages srcloc blame) + contract-violations))) + (inner (void) contract-failed obj contract message)) + + (define/public (failed-contracts) (reverse contract-violations)) + + (super-instantiate ()))) diff --git a/collects/deinprogramm/contract/contract.ss b/collects/deinprogramm/contract/contract.ss new file mode 100644 index 0000000000..349ac2f023 --- /dev/null +++ b/collects/deinprogramm/contract/contract.ss @@ -0,0 +1,252 @@ +#lang scheme/base + +(provide contract? + contract-name contract-syntax + contract-violation-proc + call-with-contract-violation-proc + make-delayed-contract + make-property-contract + make-predicate-contract + make-type-variable-contract + make-list-contract + make-mixed-contract + make-combined-contract + make-case-contract + make-procedure-contract + contract-update-syntax + apply-contract apply-contract/blame) + +(require scheme/promise + (for-syntax scheme/base) + (for-syntax stepper/private/shared)) + +; name may be #f +; enforcer: contract val -> val +; +; syntax: syntax data from where the contract was defined + +(define-struct contract (name enforcer syntax)) + +(define (contract-update-syntax ctr stx) + (struct-copy contract ctr (syntax stx))) + +; message may be #f +(define contract-violation-proc (make-parameter (lambda (obj contract message blame) + (raise (make-exn:fail:contract (or message + (format "got ~e" obj)) + (current-continuation-marks)))))) + +(define (contract-violation obj contract msg blame) + ((contract-violation-proc) obj contract msg blame)) + +(define (call-with-contract-violation-proc proc thunk) + (parameterize ((contract-violation-proc proc)) + (thunk))) + +(define (make-delayed-contract name promise syntax) + (make-contract name + (lambda (self obj) + ((contract-enforcer (force promise)) self obj)) + syntax)) + +(define (make-property-contract name access contract syntax) + (let ((enforce (contract-enforcer contract))) + (make-contract name + (lambda (self obj) + (enforce self (access obj)) ; #### problematic: enforcement doesn't stick + obj) + syntax))) + +(define (make-predicate-contract name predicate-promise syntax) + (make-contract + name + (lambda (self obj) ; dynamic binding because of syntax remapping via `contract-update-syntax' + (if ((force predicate-promise) obj) + obj + (begin + (contract-violation obj self #f #f) + obj))) + syntax)) + +(define (make-type-variable-contract name syntax) + (make-predicate-contract name (lambda (obj) #t) syntax)) + +; maps lists to pairs of contract, enforced value +(define lists-table (make-weak-hasheq)) + +(define (make-list-contract name arg-contract syntax) + (make-contract + name + (lambda (self obj) + ;;(write (list 'list obj) (current-error-port)) (newline (current-error-port)) + (let recur ((l obj)) + + (define (go-on) + (let ((enforced (cons (apply-contract arg-contract (car l)) + (recur (cdr l))))) + (hash-set! lists-table l (cons self enforced)) + (hash-set! lists-table enforced (cons self enforced)) + enforced)) + + (cond + ((null? l) + l) + ((not (pair? l)) + (contract-violation obj self #f #f) + obj) + ((hash-ref lists-table l #f) + => (lambda (seen) + ;;(write (list 'seen seen (eq? self (car seen))) (current-error-port)) (newline (current-error-port)) + (if (eq? self (car seen)) + (cdr seen) + (go-on)))) + (else + (go-on))))) + syntax)) + +(define (make-mixed-contract name alternative-contracts syntax) + (make-contract + name + (lambda (self obj) + (let loop ((alternative-contracts alternative-contracts)) + (if (null? alternative-contracts) + (begin + (contract-violation obj self #f #f) + obj) + ((let/ec exit + (let ((enforced + (call-with-contract-violation-proc + (lambda (contract syntax msg blame) + (exit (lambda () (loop (cdr alternative-contracts))))) + (lambda () + (let ((ctr (car alternative-contracts))) + (if (eq? ctr self) + (raise + (make-exn:fail:contract + (string->immutable-string + (if name + (format "rekursiver Vertrag: ~a" name) + "rekursiver Vertrag")) + (current-continuation-marks))) + (apply-contract ctr obj))))))) + (lambda () enforced))))))) + syntax)) + +(define (make-combined-contract name contracts syntax) + (make-contract + name + (lambda (self obj) + (let ((old-violation-proc (contract-violation-proc))) + ((let/ec exit + (call-with-contract-violation-proc + (lambda (contract syntax msg blame) + (exit + (lambda () + (old-violation-proc contract syntax msg blame) + obj))) + (lambda () + (let loop ((contracts contracts) + (obj obj)) + (if (null? contracts) + (lambda () obj) + (loop (cdr contracts) + (apply-contract (car contracts) obj)))))))))) + syntax)) + +(define (make-case-contract name cases syntax) + (make-contract + name + (lambda (self obj) + (let loop ((cases cases)) + (cond + ((null? cases) + (contract-violation obj self #f #f) + obj) + ((equal? (car cases) obj) + obj) + (else + (loop (cdr cases)))))) + syntax)) + +(define-struct procedure-to-blame (proc syntax)) + +(define (make-procedure-contract name arg-contracts return-contract syntax) + (let ((arg-count (length arg-contracts))) + (make-contract + name + (lambda (self thing) + (let-values (((proc blame-syntax) + (if (procedure-to-blame? thing) + (values (procedure-to-blame-proc thing) + (procedure-to-blame-syntax thing)) + (values thing #f)))) + (cond + ((not (procedure? proc)) + (contract-violation proc self #f #f)) + ((not (procedure-arity-includes? proc arg-count)) ; #### variable arity + (contract-violation proc self "wrong number of parameters" #f))) + (attach-name + (object-name proc) + (lambda args + (if (not (= (length args) arg-count)) + (begin + (contract-violation proc self "wrong number of arguments" #f) + (apply-contract return-contract (apply proc args))) + (let* ((old-violation-proc (contract-violation-proc)) + (arg-violation? #f) + (args + (call-with-contract-violation-proc + (lambda (obj contract message blame) + (set! arg-violation? #t) + (old-violation-proc obj contract message blame)) + (lambda () + (map apply-contract arg-contracts args)))) + (retval (apply proc args))) + (if arg-violation? + retval + (call-with-contract-violation-proc + (lambda (obj contract message _) + ;; blame the procedure + (old-violation-proc obj contract message blame-syntax)) + (lambda () + (apply-contract return-contract retval)))))))))) + syntax))) + +;; Matthew has promised a better way of doing this in the future. +(define (attach-name name thing) + (if (and (procedure? thing) + (symbol? name)) + (procedure-rename thing name) + thing)) + +; like apply-contract, but can track more precise blame into the contract itself +(define-syntax apply-contract/blame + (lambda (stx) + (syntax-case stx () + ((_ ?cnt-exp ?val-exp) + (syntax-case (local-expand #'?val-exp 'expression #f) (lambda #%plain-lambda) + ((lambda ?params ?body0 ?body1 ...) + (stepper-syntax-property + ;; remember there's an implicit #%app + #'(apply-contract ?cnt-exp + (make-procedure-to-blame ?val-exp + #'?val-exp)) + 'stepper-skipto/discard + '(syntax-e cdr syntax-e cdr cdr car + syntax-e cdr syntax-e cdr car))) + ((#%plain-lambda ?params ?body0 ?body1 ...) + (stepper-syntax-property + #'(apply-contract ?cnt-exp + (make-procedure-to-blame ?val-exp + #'?val-exp)) + 'stepper-skipto/discard + '(syntax-e cdr syntax-e cdr cdr car + syntax-e cdr syntax-e cdr car))) + (_ + (stepper-syntax-property + #'(apply-contract ?cnt-exp ?val-exp) + 'stepper-skipto/discard + '(syntax-e cdr syntax-e cdr cdr car)))))))) + +(define (apply-contract contract val) + ((contract-enforcer contract) contract val)) diff --git a/collects/deinprogramm/contract/module-begin.ss b/collects/deinprogramm/contract/module-begin.ss new file mode 100644 index 0000000000..0a0e01634b --- /dev/null +++ b/collects/deinprogramm/contract/module-begin.ss @@ -0,0 +1,201 @@ +#lang scheme/base + +(provide module-begin) + +(require deinprogramm/define-record-procedures + deinprogramm/contract/contract-syntax) + +(require (for-syntax scheme/base) + (for-syntax mzlib/list) + (for-syntax syntax/boundmap) + (for-syntax syntax/kerncase)) + +(define-syntax (print-results stx) + (syntax-case stx () + ((_ expr) + (not (or (syntax-property #'expr 'stepper-hide-completed) + (syntax-property #'expr 'stepper-skip-completely) + (syntax-property #'expr 'test-call))) + (syntax-property + (syntax-property + #'(#%app call-with-values (lambda () expr) + do-print-results) + 'stepper-skipto + '(syntax-e cdr cdr car syntax-e cdr cdr car)) + 'certify-mode + 'transparent)) + ((_ expr) #'expr))) + +(define (do-print-results . vs) + (for-each (current-print) vs) + ;; Returning 0 values avoids any further result printing + ;; (even if void values are printed) + (values)) + +(define-syntaxes (module-begin module-continue) + (let () + ;; takes a list of syntax objects (the result of syntax-e) and returns all the syntax objects that correspond to + ;; a contract declaration. Syntax: (: id contract) + (define extract-contracts + (lambda (lostx) + (let* ((table (make-bound-identifier-mapping)) + (non-contracts + (filter (lambda (maybe) + (syntax-case maybe (:) + ((: ?id ?cnt) + (identifier? #'id) + (begin + (when (bound-identifier-mapping-get table #'?id (lambda () #f)) + (raise-syntax-error #f + "Zweite Vertragsdefinition für denselben Namen." + maybe)) + (bound-identifier-mapping-put! table #'?id #'?cnt) + #f)) + ((: ?id) + (raise-syntax-error 'contracts "Bei dieser Vertragsdefinition fehlt der Vertrag" maybe)) + ((: ?id ?cnt ?stuff0 ?stuff1 ...) + (raise-syntax-error 'contracts "In der :-Form werden ein Name und ein Vertrag erwartet; da steht noch mehr" + (syntax/loc #'?stuff0 + (?stuff0 ?stuff1 ...)))) + (_ #t))) + lostx))) + (values table non-contracts)))) + + (define local-expand-stop-list + (append (list #': #'define-contract + #'#%require #'#%provide) + (kernel-form-identifier-list))) + + (define (expand-contract-expressions contract-table expressions) + + (let loop ((exprs expressions)) + + (cond + ((null? exprs) + (bound-identifier-mapping-for-each contract-table + (lambda (id thing) + (when thing + (if (identifier-binding id) + (raise-syntax-error #f "Zu einer eingebauten Form kann kein Vertrag erklärt werden" id) + (raise-syntax-error #f "Zu diesem Vertrag gibt es keine Definition" id))))) + #'(begin)) + (else + (let ((expanded (car exprs))) + + (syntax-case expanded (begin define-values) + ((define-values (?id ...) ?e1) + (with-syntax (((?enforced ...) + (map (lambda (id) + (with-syntax ((?id id)) + (cond + ((bound-identifier-mapping-get contract-table #'?id (lambda () #f)) + => (lambda (cnt) + (bound-identifier-mapping-put! contract-table #'?id #f) ; check for orphaned contracts + (with-syntax ((?cnt cnt)) + #'(?id ?cnt)))) + (else + #'?id)))) + (syntax->list #'(?id ...)))) + (?rest (loop (cdr exprs)))) + (with-syntax ((?defn + (syntax-track-origin + #'(define-values/contract (?enforced ...) + ?e1) + (car exprs) + (car (syntax-e expanded))))) + + (syntax/loc (car exprs) + (begin + ?defn + ?rest))))) + ((begin e1 ...) + (loop (append (syntax-e (syntax (e1 ...))) (cdr exprs)))) + (else + (with-syntax ((?first expanded) + (?rest (loop (cdr exprs)))) + (syntax/loc (car exprs) + (begin + ?first ?rest)))))))))) + (values + ;; module-begin + (lambda (stx) + (syntax-case stx () + ((_ e1 ...) + ;; module-begin-continue takes a sequence of expanded + ;; exprs and a sequence of to-expand exprs; that way, + ;; the module-expansion machinery can be used to handle + ;; requires, etc.: + #`(#%plain-module-begin + (module-continue (e1 ...) () ()))))) + + ;; module-continue + (lambda (stx) + (syntax-case stx () + ((_ () (e1 ...) (defined-id ...)) + ;; Local-expanded all body elements, lifted out requires, etc. + ;; Now process the result. + (begin + ;; The expansion for contracts breaks the way that beginner-define, etc., + ;; check for duplicate definitions, so we have to re-check here. + ;; A better strategy might be to turn every define into a define-syntax + ;; to redirect the binding, and then the identifier-binding check in + ;; beginner-define, etc. will work. + (let ((defined-ids (make-bound-identifier-mapping))) + (for-each (lambda (id) + (when (bound-identifier-mapping-get defined-ids id (lambda () #f)) + (raise-syntax-error + #f + "Für diesen Namen gibt es schon eine Definition." + id)) + (bound-identifier-mapping-put! defined-ids id #t)) + (reverse (syntax->list #'(defined-id ...))))) + ;; Now handle contracts: + (let ((top-level (reverse (syntax->list (syntax (e1 ...)))))) + (let-values (((cnt-table expr-list) + (extract-contracts top-level))) + (expand-contract-expressions cnt-table expr-list))))) + ((frm e3s e1s def-ids) + (let loop ((e3s #'e3s) + (e1s #'e1s) + (def-ids #'def-ids)) + (syntax-case e3s () + (() + #`(frm () #,e1s #,def-ids)) + ((e2 . e3s) + (let ((e2 (local-expand #'e2 'module local-expand-stop-list))) + ;; Lift out certain forms to make them visible to the module + ;; expander: + (syntax-case e2 (#%require #%provide + define-syntaxes define-values-for-syntax define-values begin + define-record-procedures define-record-procedures-2 + define-record-procedures-parametric define-record-procedures-parametric-2 + define-contract :) + ((#%require . __) + #`(begin #,e2 (frm e3s #,e1s #,def-ids))) + ((#%provide . __) + #`(begin #,e2 (frm e3s #,e1s #,def-ids))) + ((define-syntaxes (id ...) . _) + #`(begin #,e2 (frm e3s #,e1s (id ... . #,def-ids)))) + ((define-values-for-syntax . _) + #`(begin #,e2 (frm e3s #,e1s #,def-ids))) + ((begin b1 ...) + (syntax-track-origin + (loop (append (syntax->list #'(b1 ...)) #'e3s) e1s def-ids) + e2 + (car (syntax-e e2)))) + ((define-values (id ...) . _) + (loop #'e3s (cons e2 e1s) (append (syntax->list #'(id ...)) def-ids))) + ((define-contract id ctr) + (loop #'e3s (cons e2 e1s) def-ids)) + ((define-record-procedures id cns prd (spec ...)) + (loop #'e3s (cons e2 e1s) def-ids)) + ((define-record-procedures-2 id cns prd (spec ...)) + (loop #'e3s (cons e2 e1s) def-ids)) + ((define-record-procedures-parametric id cns prd (spec ...)) + (loop #'e3s (cons e2 e1s) def-ids)) + ((define-record-procedures-parametric-2 id cns prd (spec ...)) + (loop #'e3s (cons e2 e1s) def-ids)) + ((: stuff ...) + (loop #'e3s (cons e2 e1s) def-ids)) + (_ + (loop #'e3s (cons #`(print-results #,e2) e1s) def-ids))))))))))))) diff --git a/collects/deinprogramm/convert-explicit.scm b/collects/deinprogramm/convert-explicit.scm new file mode 100644 index 0000000000..23887efbad --- /dev/null +++ b/collects/deinprogramm/convert-explicit.scm @@ -0,0 +1,89 @@ +;; I HATE DEFINE-STRUCT! +(define-struct/properties :empty-list () + ((prop:custom-write + (lambda (r port write?) + (write-string "#" port)))) + (make-inspector)) + +(define the-empty-list (make-:empty-list)) + +;; essentially copied from define-record-procedures.scm +(define (write-list l port write?) + (let ((pp? (and (pretty-printing) + (number? (pretty-print-columns))))) + + (write-string "#<" port) + (write-string "list" port) + + (let-values (((ref-line ref-column ref-pos) + (if pp? + (port-next-location port) + (values 0 -1 0)))) ; to compensate for space + (let ((do-element + (if pp? + (lambda (element) + (let* ((max-column (- (pretty-print-columns) 1)) ; > terminator + (tentative + (make-tentative-pretty-print-output-port + port + max-column + void))) + (display " " tentative) + ((if write? write display) element tentative) + (let-values (((line column pos) (port-next-location tentative))) + (if (< column max-column) + (tentative-pretty-print-port-transfer tentative port) + (begin + (tentative-pretty-print-port-cancel tentative) + (let ((count (pretty-print-newline port max-column))) + (write-string (make-string (max 0 (- (+ ref-column 1) count)) #\space) + port) + ((if write? write display) element port))))))) + (lambda (element) + (display " " port) + ((if write? write display) element port))))) + (let loop ((elements (:list-elements l))) + (cond + ((pair? elements) + (do-element (car elements)) + (loop (cdr elements))) + ((not (null? elements)) + (write-string " ." port) + (do-element elements)))))) + + (write-string ">" port))) + +;; might be improper +(define-struct/properties :list (elements) + ((prop:custom-write write-list)) + (make-inspector)) + +;; doesn't handle cycles +(define (convert-explicit v) + (cond + ((null? v) the-empty-list) + ((pair? v) ; need to check for sharing + (make-:list + (let recur ((v v)) + (cond + ((null? v) + v) + ((not (pair? v)) + (convert-explicit v)) + (else + (cons (convert-explicit (car v)) + (recur (cdr v)))))))) + ((deinprogramm-struct? v) + (let*-values (((ty skipped?) (struct-info v)) + ((name-symbol + init-field-k auto-field-k accessor-proc mutator-proc immutable-k-list + super-struct-type skipped?) + (struct-type-info ty))) + (apply (struct-type-make-constructor ty) + (map convert-explicit + (map (lambda (index) + (accessor-proc v index)) + (iota (+ init-field-k auto-field-k))))))) + (else + v))) + diff --git a/collects/deinprogramm/convert-explicit.ss b/collects/deinprogramm/convert-explicit.ss new file mode 100644 index 0000000000..601d1313c7 --- /dev/null +++ b/collects/deinprogramm/convert-explicit.ss @@ -0,0 +1,11 @@ +#lang scheme/base +(provide convert-explicit) + +(require mzlib/pretty + mzlib/struct + (only-in srfi/1 iota)) + +(require deinprogramm/deinprogramm-struct) + +(require scheme/include) +(include "convert-explicit.scm") diff --git a/collects/deinprogramm/define-record-procedures.scm b/collects/deinprogramm/define-record-procedures.scm new file mode 100644 index 0000000000..a4376d3e25 --- /dev/null +++ b/collects/deinprogramm/define-record-procedures.scm @@ -0,0 +1,511 @@ +;; (define-record-procedures-2 :pare kons pare? ((kar set-kar!) kdr)) + +(define-syntax define-record-procedures* + + (let () + (define (filter-map proc l) + (if (null? l) + '() + (let ((result (proc (car l)))) + (if result + (cons result (filter-map proc (cdr l))) + (filter-map proc (cdr l)))))) + + + (define (syntax-member? thing stuff) + (cond + ((null? stuff) #f) + ((free-identifier=? thing (car stuff)) #t) + (else (syntax-member? thing (cdr stuff))))) + + (define (map-with-index proc list) + (let loop ((i 0) (list list) (rev-result '())) + (if (null? list) + (reverse rev-result) + (loop (+ 1 i) + (cdr list) + (cons (proc i (car list)) rev-result))))) + + (lambda (x) + (syntax-case x () + ((_ ?type-spec + ?constructor + ?predicate + (?field-spec ...)) + + (with-syntax + ((?type-name (syntax-case #'?type-spec () + ((?id ?param ...) + #'?id) + (?id + #'?id))) + ((accessor ...) + (map (lambda (field-spec) + (syntax-case field-spec () + ((accessor mutator) (syntax accessor)) + (accessor (syntax accessor)))) + (syntax->list (syntax (?field-spec ...))))) + ((mutator ...) + (map (lambda (field-spec dummy-mutator) + (syntax-case field-spec () + ((accessor mutator) (syntax mutator)) + (accessor dummy-mutator))) + (syntax->list (syntax (?field-spec ...))) + (generate-temporaries (syntax (?field-spec ...)))))) + (with-syntax + ((number-of-fields (length (syntax->list + (syntax (accessor ...))))) + (generic-access (syntax generic-access)) + (generic-mutate (syntax generic-mutate))) + (with-syntax + (((accessor-proc ...) + (map-with-index + (lambda (i accessor) + (with-syntax ((i i) + (tag accessor)) + (syntax-property (syntax/loc + accessor + (lambda (s) + (when (not (?predicate s)) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "~a: Argument kein ~a: ~e" + 'tag '?type-name s)) + (current-continuation-marks)))) + (generic-access s i))) + 'inferred-name + (syntax-e accessor)))) + (syntax->list (syntax (accessor ...))))) + ((our-accessor ...) (generate-temporaries #'(accessor ...))) + ((mutator-proc ...) + (map-with-index + (lambda (i mutator) + (with-syntax ((i i) + (tag mutator)) + (syntax-property (syntax/loc + mutator + (lambda (s v) + (when (not (?predicate s)) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "~a: Argument kein ~a: ~e" + 'tag '?type-name s)) + (current-continuation-marks)))) + (generic-mutate s i v))) + 'inferred-name + (syntax-e mutator)))) + (syntax->list (syntax (mutator ...))))) + (constructor-proc + (syntax-property (syntax + (lambda (accessor ...) + (?constructor accessor ...))) + 'inferred-name + (syntax-e (syntax ?constructor)))) + (predicate-proc + (syntax-property (syntax + (lambda (thing) + (?predicate thing))) + 'inferred-name + (syntax-e (syntax ?predicate)))) + (constructor-name (syntax ?constructor))) + (with-syntax + ((defs + #'(define-values (?constructor + ?predicate real-predicate + accessor ... + our-accessor ... + mutator ...) + (letrec-values (((type-descriptor + ?constructor + ?predicate + generic-access + generic-mutate) + (make-struct-type + '?type-name #f number-of-fields 0 + #f + (list + (cons prop:print-convert-constructor-name + 'constructor-name) + (cons prop:deinprogramm-struct + #t) + (cons prop:custom-write + (lambda (r port write?) + (custom-write-record '?type-name + (access-record-fields r generic-access number-of-fields) + port write?)))) + (make-inspector)))) + (values constructor-proc + predicate-proc predicate-proc + accessor-proc ... + accessor-proc ... + mutator-proc ...)))) + (contract + (syntax-case #'?type-spec () + ((_ ?param ...) + (with-syntax (((component-contract ...) + (map (lambda (accessor param) + (with-syntax ((?accessor accessor) + (?param param)) + #'(at ?param (property ?accessor ?param)))) + (syntax->list #'(our-accessor ...)) + (syntax->list #'(?param ...))))) + #'(define-contract ?type-spec + (combined (at ?type-name (predicate real-predicate)) + component-contract ...)))) + (_ + ;; we use real-predicate to avoid infinite recursion if a contract + ;; for ?type-name using ?predicate is inadvertently defined + #'(define-contract ?type-name (predicate real-predicate)))))) + (with-syntax ((defs + (stepper-syntax-property + (syntax/loc x defs) 'stepper-skip-completely #t)) + (contract + (stepper-syntax-property + #'contract + 'stepper-skip-completely #t))) + + #'(begin + contract + ;; the contract might be used in the definitions, hence this ordering + defs))))))) + + ((_ ?type-name + ?constructor + ?predicate + rest) + (raise-syntax-error + #f + "Der vierte Operand ist illegal" (syntax rest))) + ((_ ?type-name + ?constructor + ?predicate + rest1 rest2 ... (?field-spec ...)) + (raise-syntax-error + #f + "Vor den Selektoren/Mutatoren steht eine Form zuviel" #'rest1)) + ((_ ?type-name + ?constructor + ?predicate + rest1 rest2 ...) + (raise-syntax-error + #f + "Zu viele Operanden für define-record-procedures-2" x)) + ((_ arg1 ...) + (raise-syntax-error + #f + "Zu wenige Operanden für define-record-procedures-2" x)))))) + +(define (access-record-fields rec acc count) + (let recur ((i 0)) + (if (= i count) + '() + (cons (acc rec i) + (recur (+ i 1)))))) + +#| +(define-record-procedures :pare kons pare? (kar kdr)) +(kons 1 (kons 2 (kons 3 (kons 5 (kons 6 (kons 7 (kons 8 "asdjkfdshfdsjkf"))))))) + +prints as: + +#>>>>>> + +|# + +(define (custom-write-record name field-values port write?) + (let ((pp? (and (pretty-printing) + (number? (pretty-print-columns))))) + + (write-string "#<" port) + (write-string "record" port) + (let ((name (symbol->string name))) + (when (not (and (positive? (string-length name)) + (char=? #\: (string-ref name 0)))) + (write-char #\: port)) + (write-string name port)) + + (let-values (((ref-line ref-column ref-pos) + (if pp? + (port-next-location port) + (values 0 -1 0)))) ; to compensate for space + (for-each + (if pp? + (lambda (field-value) + (let* ((max-column (- (pretty-print-columns) 1)) ; > terminator + (tentative + (make-tentative-pretty-print-output-port + port + max-column + void))) + (display " " tentative) + ((if write? write display) field-value tentative) + (let-values (((line column pos) (port-next-location tentative))) + (if (< column max-column) + (tentative-pretty-print-port-transfer tentative port) + (begin + (tentative-pretty-print-port-cancel tentative) + (let ((count (pretty-print-newline port max-column))) + (write-string (make-string (max 0 (- (+ ref-column 1) count)) #\space) + port) + ((if write? write display) field-value port))))))) + (lambda (field-value) + (display " " port) + ((if write? write display) field-value port))) + field-values) + + (write-string ">" port)))) + +;; (define-record-procedures :pare kons pare? (kar kdr)) + +(define-syntax define-record-procedures + (lambda (x) + (syntax-case x () + ((_ ?type-name + ?constructor + ?predicate + (accessor ...)) + + (begin + (check-for-id! + (syntax ?type-name) + "Typ-Name ist kein Bezeichner") + + (check-for-id! + (syntax ?constructor) + "Konstruktor ist kein Bezeichner") + + (check-for-id! + (syntax ?predicate) + "Prädikat ist kein Bezeichner") + + (check-for-id-list! + (syntax->list (syntax (accessor ...))) + "Selektor ist kein Bezeichner") + + (with-syntax (((dummy-mutator ...) + (generate-temporaries (syntax (accessor ...))))) + (syntax + (define-record-procedures* ?type-name + ?constructor + ?predicate + ((accessor dummy-mutator) ...)))))) + + ((_ ?type-name + ?constructor + ?predicate + rest) + (raise-syntax-error + #f + "Der vierte Operand ist keine Liste von Selektoren" (syntax rest))) + ((_ ?type-name + ?constructor + ?predicate + rest1 rest2 ... (accessor ...)) + (raise-syntax-error + #f + "Vor den Selektoren steht eine Form zuviel" #'rest1)) + ((_ ?type-name + ?constructor + ?predicate + rest1 rest2 ...) + (raise-syntax-error + #f + "Zu viele Operanden für define-record-procedures" x)) + ((_ arg1 ...) + (raise-syntax-error + #f + "Zu wenige Operanden für define-record-procedures" x)) + ))) + +(define-syntax define-record-procedures-parametric + (lambda (x) + (syntax-case x () + ((_ (?type-name ?param ...) + ?constructor + ?predicate + (accessor ...)) + + + (begin + (check-for-id-list! (syntax->list #'(?param ...)) + "Parameter ist kein Bezeichner") + (when (not (= (length (syntax->list #'(?param ...))) + (length (syntax->list #'(accessor ...))))) + (raise-syntax-error #f + (string-append "Anzahlen der Konstruktor-Parameter " + "und der Felder sollten übereinstimmen") + #'?constructor)) + (check-for-id! + (syntax ?constructor) + "Konstruktor ist kein Bezeichner") + + (check-for-id! + (syntax ?type-name) + "Typ-Name ist kein Bezeichner") + + (for-each (lambda (param) + (check-for-id! param + "Parameter ist kein Bezeichner")) + (syntax->list #'(?param ...))) + + (check-for-id! + (syntax ?predicate) + "Prädikat ist kein Bezeichner") + + (check-for-id-list! + (syntax->list (syntax (accessor ...))) + "Selektor ist kein Bezeichner") + + (with-syntax (((dummy-mutator ...) + (generate-temporaries (syntax (accessor ...))))) + (syntax + (define-record-procedures* (?type-name ?param ...) + ?constructor + ?predicate + ((accessor dummy-mutator) ...)))))) + + ((_ ?type-name + ?constructor + ?predicate + rest) + (raise-syntax-error + #f + "Der vierte Operand ist keine Liste von Selektoren" (syntax rest))) + ((_ ?type-name + ?constructor + ?predicate + rest1 rest2 ...) + (raise-syntax-error + #f + "Zu viele Operanden für define-record-procedures-polymorphic" x)) + ((_ arg1 ...) + (raise-syntax-error + #f + "Zu wenige Operanden für define-record-procedures-polymorphic" x)) + ))) + +(define-syntax define-record-procedures-2 + (lambda (x) + (syntax-case x () + ((_ ?type-name + ?constructor + ?predicate + (?field-spec ...)) + + (begin + (check-for-id! + (syntax ?type-name) + "Typ-Name ist kein Bezeichner") + + (check-for-id! + (syntax ?constructor) + "Konstruktor ist kein Bezeichner") + + (check-for-id! + (syntax ?predicate) + "Prädikat ist kein Bezeichner") + + (for-each (lambda (field-spec) + (syntax-case field-spec () + ((accessor mutator) + (check-for-id! (syntax accessor) + "Selektor ist kein Bezeichner") + (check-for-id! (syntax mutator) + "Mutator ist kein Bezeichner")) + (accessor + (check-for-id! (syntax accessor) + "Selektor ist kein Bezeichner")))) + (syntax->list (syntax (?field-spec ...)))) + + #'(define-record-procedures* ?type-name + ?constructor + ?predicate + (?field-spec ...)))) + ((_ ?type-name + ?constructor + ?predicate + rest) + (raise-syntax-error + #f + "Der vierte Operand ist illegal" (syntax rest))) + ((_ ?type-name + ?constructor + ?predicate + rest1 rest2 ...) + (raise-syntax-error + #f + "Zu viele Operanden für define-record-procedures-2" x)) + ((_ arg1 ...) + (raise-syntax-error + #f + "Zu wenige Operanden für define-record-procedures-2" x))))) + +(define-syntax define-record-procedures-parametric-2 + (lambda (x) + (syntax-case x () + ((_ (?type-name ?param ...) + ?constructor + ?predicate + (?field-spec ...)) + + (begin + (check-for-id-list! (syntax->list #'(?param ...)) + "Parameter ist kein Bezeichner") + (when (not (= (length (syntax->list #'(?param ...))) + (length (syntax->list #'(?field-spec ...))))) + (raise-syntax-error #f + (string-append "Anzahlen der Konstruktor-Parameter " + "und der Felder sollten übereinstimmen") + #'?constructor)) + + (check-for-id! + (syntax ?constructor) + "Konstruktor ist kein Bezeichner") + + (check-for-id! + (syntax ?predicate) + "Prädikat ist kein Bezeichner") + + (for-each (lambda (field-spec) + (syntax-case field-spec () + ((accessor mutator) + (check-for-id! (syntax accessor) + "Selektor ist kein Bezeichner") + (check-for-id! (syntax mutator) + "Mutator ist kein Bezeichner")) + (accessor + (check-for-id! (syntax accessor) + "Selektor ist kein Bezeichner")))) + (syntax->list (syntax (?field-spec ...)))) + + #'(define-record-procedures* (?type-name ?param ...) + ?constructor + ?predicate + (?field-spec ...)))) + ((_ ?type-name + ?constructor + ?predicate + rest) + (raise-syntax-error + #f + "Der vierte Operand ist illegal" (syntax rest))) + ((_ ?type-name + ?constructor + ?predicate + rest1 rest2 ...) + (raise-syntax-error + #f + "Zu viele Operanden für define-record-procedures-2" x)) + ((_ arg1 ...) + (raise-syntax-error + #f + "Zu wenige Operanden für define-record-procedures-2" x))))) + + diff --git a/collects/deinprogramm/define-record-procedures.ss b/collects/deinprogramm/define-record-procedures.ss new file mode 100644 index 0000000000..becc4d98d7 --- /dev/null +++ b/collects/deinprogramm/define-record-procedures.ss @@ -0,0 +1,17 @@ +#lang scheme/base + +(provide define-record-procedures + define-record-procedures-parametric + define-record-procedures-2 + define-record-procedures-parametric-2) + +(require scheme/include + mzlib/pconvert-prop + mzlib/pretty + deinprogramm/contract/contract-syntax) + +(require deinprogramm/deinprogramm-struct) +(require (for-syntax scheme/base) + (for-syntax deinprogramm/syntax-checkers) + (for-syntax stepper/private/shared)) +(include "define-record-procedures.scm") diff --git a/collects/deinprogramm/deinprogramm-langs.ss b/collects/deinprogramm/deinprogramm-langs.ss new file mode 100644 index 0000000000..5fa33a405f --- /dev/null +++ b/collects/deinprogramm/deinprogramm-langs.ss @@ -0,0 +1,1592 @@ +#lang scheme/base + +(require string-constants + framework + (prefix-in et: errortrace/stacktrace) + (prefix-in tr: trace/stacktrace) + mzlib/pretty + (prefix-in pc: mzlib/pconvert) + mzlib/file + mzlib/unit + mzlib/class + mzlib/list + mzlib/struct + mzlib/compile + drscheme/tool + mred + framework/private/bday + syntax/moddep + mrlib/cache-image-snip + compiler/embed + wxme/wxme + setup/dirs + + ;; this module is shared between the drscheme's namespace (so loaded here) + ;; and the user's namespace in the teaching languages + "deinprogramm-struct.ss" + + lang/stepper-language-interface + lang/debugger-language-interface + lang/run-teaching-program + stepper/private/shared + + (only-in test-engine/scheme-gui make-formatter) + (only-in test-engine/scheme-tests scheme-test-data error-handler test-format test-execute) + deinprogramm/contract/contract + deinprogramm/contract/contract-test-engine + deinprogramm/contract/contract-test-display + ) + + + (require mzlib/pconvert-prop) + + (require "convert-explicit.ss") + + (require (only-in mrlib/syntax-browser render-syntax/snip)) + + (provide tool@) + + (define sc-tracing (string-constant tracing-enable-tracing)) + (define sc-show-tracing-window (string-constant tracing-show-tracing-window)) + (define sc-hide-tracing-window (string-constant tracing-hide-tracing-window)) + (define sc-tracing-nothing-to-show (string-constant tracing-tracing-nothing-to-show)) + + (define ellipses-cutoff 200) + + (define o (current-output-port)) + (define (oprintf . args) (apply fprintf o args)) + + (define user-installed-teachpacks-collection "installed-teachpacks") + (define teachpack-installation-dir (build-path (find-user-collects-dir) user-installed-teachpacks-collection)) + + ;; adapted from collects/drscheme/private/main.ss + (preferences:set-default 'drscheme:deinprogramm:last-set-teachpacks + '() + (lambda (x) + (and (list? x) + (andmap (lambda (x) + (and (list? x) + (pair? x) + (eq? (car x) 'lib) + (andmap string? (cdr x)))) + x)))) + + + (define tool@ + (unit + (import drscheme:tool^) + (export drscheme:tool-exports^) + (define-local-member-name + get-tracing-text + show-tracing + tracing:add-line + tracing:rest) + (define tab-tracing<%> + (interface () + get-tracing-text + get-any-results? + tracing:add-line + tracing:reset)) + + + (define drs-eventspace (current-eventspace)) + + ;; writing-style : {explicit, datum} + ;; tracing? : boolean + ;; teachpacks : (listof require-spec) + (define-struct (deinprogramm-lang-settings drscheme:language:simple-settings) + (writing-style tracing? teachpacks)) + (define deinprogramm-lang-settings->vector (make-->vector deinprogramm-lang-settings)) + + (define image-string "") + + (define deinprogramm-language<%> + (interface () + get-module + get-language-position + get-sharing-printing + get-abbreviate-cons-as-list + get-allow-sharing? + get-use-function-output-syntax? + get-accept-quasiquote? + get-read-accept-dot)) + + ;; module-based-language-extension : (implements drscheme:language:module-based-language<%>) + ;; -> (implements drscheme:language:module-based-language<%>) + ;; changes the default settings and sets a few more paramters during `on-execute' + (define (module-based-language-extension printing-style writing-style super%) + (class* super% () + + (inherit get-sharing-printing get-abbreviate-cons-as-list) + + (define/override (default-settings) + (make-deinprogramm-lang-settings + #f + printing-style + 'repeating-decimal + (get-sharing-printing) + #t + 'none + writing-style + #f + (preferences:get 'drscheme:deinprogramm:last-set-teachpacks))) + + (define/override (default-settings? s) + (and (not (drscheme:language:simple-settings-case-sensitive s)) + (eq? (drscheme:language:simple-settings-printing-style s) + printing-style) + (eq? (drscheme:language:simple-settings-fraction-style s) + 'repeating-decimal) + (eqv? (drscheme:language:simple-settings-show-sharing s) + (get-sharing-printing)) + (drscheme:language:simple-settings-insert-newlines s) + (eq? (drscheme:language:simple-settings-annotations s) + 'none) + (eq? writing-style (deinprogramm-lang-settings-writing-style s)) + (not (deinprogramm-lang-settings-tracing? s)) + (null? (deinprogramm-lang-settings-teachpacks s)))) + + (define/override (marshall-settings x) + (list (super marshall-settings x) + (deinprogramm-lang-settings-writing-style x) + (deinprogramm-lang-settings-tracing? x) + (deinprogramm-lang-settings-teachpacks x))) + + (define/override (unmarshall-settings x) + (if (and (list? x) + (= (length x) 4) + (symbol? (list-ref x 1)) ; #### + (boolean? (list-ref x 2)) + (list-of-require-specs? (list-ref x 3))) + (let ([drs-settings (super unmarshall-settings (first x))]) + (make-deinprogramm-lang-settings + (drscheme:language:simple-settings-case-sensitive drs-settings) + (drscheme:language:simple-settings-printing-style drs-settings) + (drscheme:language:simple-settings-fraction-style drs-settings) + (drscheme:language:simple-settings-show-sharing drs-settings) + (drscheme:language:simple-settings-insert-newlines drs-settings) + (drscheme:language:simple-settings-annotations drs-settings) + (cadr x) + (caddr x) + (cadddr x))) + (default-settings))) + + (define/private (list-of-require-specs? l) + (and (list? l) + (andmap (lambda (x) + (and (list? x) + (andmap (lambda (x) (or (string? x) (symbol? x))) x))) + l))) + + (inherit get-allow-sharing? get-use-function-output-syntax? + get-accept-quasiquote? get-read-accept-dot) + (define/override (config-panel parent) + (sharing/not-config-panel (get-allow-sharing?) (get-accept-quasiquote?) parent)) + + (define/override (on-execute settings run-in-user-thread) + (let ([drs-namespace (current-namespace)] + [deinprogramm-struct-module-name + ((current-module-name-resolver) '(lib "deinprogramm/deinprogramm-struct.ss") #f #f)] + [scheme-test-module-name + ((current-module-name-resolver) '(lib "test-engine/scheme-tests.ss") #f #f)] + [scheme-contract-module-name + ((current-module-name-resolver) '(lib "deinprogramm/contract/contract.ss") #f #f)]) + (run-in-user-thread + (lambda () + (read-accept-quasiquote (get-accept-quasiquote?)) + (namespace-attach-module drs-namespace ''drscheme-secrets) + (namespace-attach-module drs-namespace deinprogramm-struct-module-name) + (error-display-handler teaching-languages-error-display-handler) + + (current-eval (add-annotation (deinprogramm-lang-settings-tracing? settings) (current-eval))) + + (error-print-source-location #f) + (read-decimal-as-inexact #t) + (read-accept-dot (get-read-accept-dot)) + (namespace-attach-module drs-namespace scheme-test-module-name) + (namespace-require scheme-test-module-name) + + (namespace-attach-module drs-namespace scheme-contract-module-name) + (namespace-require scheme-contract-module-name) + + ;; DeinProgramm hack: the test-engine code knows about the test~object name; we do, too + (namespace-set-variable-value! 'test~object (build-contract-test-engine)) + ;; record test-case failures with the test engine + (contract-violation-proc + (lambda (obj contract message blame) + (cond + ((namespace-variable-value 'test~object #f (lambda () #f)) + => (lambda (engine) + (send (send engine get-info) contract-failed + obj contract message blame)))))) + (scheme-test-data (list (drscheme:rep:current-rep) drs-eventspace contract-test-display%)) + (test-execute (get-preference 'tests:enable? (lambda () #t))) + (test-format (make-formatter (lambda (v o) (render-value/format v settings o 40)))) + ))) + (super on-execute settings run-in-user-thread) + + ;; DeinProgramm addition, copied from language.ss + (run-in-user-thread + (lambda () + (global-port-print-handler + (lambda (value port) + (let ([converted-value (simple-module-based-language-convert-value value settings)]) + (setup-printing-parameters + (lambda () + (parameterize ([pretty-print-columns 'infinity]) + (pretty-print converted-value port))) + settings + 'infinity))))))) + + ;; set-printing-parameters : settings ( -> TST) -> TST + ;; is implicitly exposed to the stepper. watch out! -- john + (define/public (set-printing-parameters settings thunk) + (parameterize ([pc:booleans-as-true/false #f] + [pc:abbreviate-cons-as-list (get-abbreviate-cons-as-list)] + [pretty-print-show-inexactness #f] + [pretty-print-exact-as-decimal #f] + [pc:use-named/undefined-handler + (lambda (x) + (and (get-use-function-output-syntax?) + (procedure? x) + (object-name x)))] + [pc:named/undefined-handler + (lambda (x) + (string->symbol + (format "function:~a" (object-name x))))]) + (thunk))) + + (define/override (render-value/format value settings port width) + (set-printing-parameters + settings + (lambda () + (simple-module-based-language-render-value/format value settings port width)))) + + (define/override (render-value value settings port) + (set-printing-parameters + settings + (lambda () + (simple-module-based-language-render-value/format value settings port 'infinity)))) + + (super-new))) + + ;; { + ;; all this copied from collects/drscheme/private/language.ss + + ;; stepper-convert-value : TST settings -> TST + (define (stepper-convert-value value settings) + (define ((leave-snips-alone-hook sh) expr basic-convert sub-convert) + (if (or (is-a? expr snip%) + ;; FIXME: internal in language.ss (to-snip-value? expr) + ) + expr + (sh expr basic-convert sub-convert))) + ;; mflatt: MINOR HACK - work around temporary + ;; print-convert problems + (define (stepper-print-convert v) + (or (and (procedure? v) (object-name v)) + (pc:print-convert v))) + + (case (drscheme:language:simple-settings-printing-style settings) + [(write) + (let ((v (convert-explicit value))) + (or (and (procedure? v) (object-name v)) + v))] + [(current-print) value] + [(constructor) + (parameterize + ([pc:constructor-style-printing #t] + [pc:show-sharing + (drscheme:language:simple-settings-show-sharing settings)] + [pc:current-print-convert-hook + (leave-snips-alone-hook (pc:current-print-convert-hook))]) + (stepper-print-convert value))] + [(quasiquote) + (parameterize + ([pc:constructor-style-printing #f] + [pc:show-sharing + (drscheme:language:simple-settings-show-sharing settings)] + [pc:current-print-convert-hook + (leave-snips-alone-hook (pc:current-print-convert-hook))]) + (stepper-print-convert value))] + [else (error "Internal stepper error: time to resync with simple-module-based-language-convert-value")])) + + ;; set-print-settings ; settings ( -> TST) -> TST + (define (set-print-settings language simple-settings thunk) + (if (method-in-interface? 'set-printing-parameters (object-interface language)) + (send language set-printing-parameters simple-settings thunk) + ;; assume that the current print-convert context is fine + ;; (error 'stepper-tool "language object does not contain set-printing-parameters method") + (thunk))) + + ;; simple-module-based-language-render-value/format : TST settings port (union #f (snip% -> void)) (union 'infinity number) -> void + (define (simple-module-based-language-render-value/format value settings port width) + (if (eq? (drscheme:language:simple-settings-printing-style settings) 'current-print) + (parameterize ([current-output-port port]) + ((current-print) value)) + (let ([converted-value (simple-module-based-language-convert-value value settings)]) + (setup-printing-parameters + (lambda () + (cond + [(drscheme:language:simple-settings-insert-newlines settings) + (if (number? width) + (parameterize ([pretty-print-columns width]) + (pretty-print converted-value port)) + (pretty-print converted-value port))] + [else + (parameterize ([pretty-print-columns 'infinity]) + (pretty-print converted-value port)) + (newline port)])) + settings + width)))) + + ;; setup-printing-parameters : (-> void) -> void + (define (setup-printing-parameters thunk settings width) + (let ([use-number-snip? + (lambda (x) + (and (number? x) + (exact? x) + (real? x) + (not (integer? x))))]) + (parameterize (;; these three handlers aren't used, but are set to override the user's settings + [pretty-print-print-line (lambda (line-number op old-line dest-columns) + (when (and (not (equal? line-number 0)) + (not (equal? dest-columns 'infinity))) + (newline op)) + 0)] + [pretty-print-pre-print-hook (lambda (val port) (void))] + [pretty-print-post-print-hook (lambda (val port) (void))] + + + [pretty-print-columns width] + [pretty-print-size-hook + (lambda (value display? port) + (cond + [(not (port-writes-special? port)) #f] + [(is-a? value snip%) 1] + [(use-number-snip? value) 1] + [(syntax? value) 1] + [(to-snip-value? value) 1] + [else #f]))] + [pretty-print-print-hook + (lambda (value display? port) + (cond + [(is-a? value snip%) + (write-special value port) + 1] + [(use-number-snip? value) + (write-special + (case (drscheme:language:simple-settings-fraction-style settings) + [(mixed-fraction) + (number-snip:make-fraction-snip value #f)] + [(mixed-fraction-e) + (number-snip:make-fraction-snip value #t)] + [(repeating-decimal) + (number-snip:make-repeating-decimal-snip value #f)] + [(repeating-decimal-e) + (number-snip:make-repeating-decimal-snip value #t)]) + port) + 1] + [(syntax? value) + (write-special (render-syntax/snip value) port)] + [else (write-special (value->snip value) port)]))] + [print-graph + ;; only turn on print-graph when using `write' printing + ;; style because the sharing is being taken care of + ;; by the print-convert sexp construction when using + ;; other printing styles. + (and (eq? (drscheme:language:simple-settings-printing-style settings) 'write) + (drscheme:language:simple-settings-show-sharing settings))]) + (thunk)))) + + ;; DeinProgramm changes in this procedure + ;; simple-module-based-language-convert-value : TST settings -> TST + (define (simple-module-based-language-convert-value value settings) + (case (drscheme:language:simple-settings-printing-style settings) + [(write) + ;; THIS IS THE CHANGE + (case (deinprogramm-lang-settings-writing-style settings) + [(explicit) (convert-explicit value)] + [(datum) value])] + [(current-print) value] + [(constructor) + (parameterize ([pc:constructor-style-printing #t] + [pc:show-sharing (drscheme:language:simple-settings-show-sharing settings)] + [pc:current-print-convert-hook (leave-snips-alone-hook (pc:current-print-convert-hook))]) + (pc:print-convert value))] + [(quasiquote) + (parameterize ([pc:constructor-style-printing #f] + [pc:show-sharing (drscheme:language:simple-settings-show-sharing settings)] + [pc:current-print-convert-hook (leave-snips-alone-hook (pc:current-print-convert-hook))]) + (pc:print-convert value))])) + + ;; leave-snips-alone-hook : any? (any? -> printable) any? -> printable + (define ((leave-snips-alone-hook sh) expr basic-convert sub-convert) + (if (is-a? expr snip%) + expr + (sh expr basic-convert sub-convert))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; snip/value extensions + ;; + + (define to-snips null) + (define-struct to-snip (predicate? >value)) + (define (add-snip-value predicate constructor) + (set! to-snips (cons (make-to-snip predicate constructor) to-snips))) + + (define (value->snip v) + (ormap (lambda (to-snip) (and ((to-snip-predicate? to-snip) v) + ((to-snip->value to-snip) v))) + to-snips)) + (define (to-snip-value? v) + (ormap (lambda (to-snip) ((to-snip-predicate? to-snip) v)) to-snips)) + + + ;; } + + ;; sharing/not-config-panel : boolean boolean parent -> (case-> (-> settings) (settings -> void)) + ;; constructs the config-panel for a language without a sharing option. + (define (sharing/not-config-panel allow-sharing-config? accept-quasiquote? _parent) + (let* ([parent (make-object vertical-panel% _parent)] + + [input-panel (instantiate group-box-panel% () + (parent parent) + (label (string-constant input-syntax)) + (alignment '(left center)))] + + [output-panel (instantiate group-box-panel% () + (parent parent) + (label (string-constant output-syntax)) + (alignment '(left center)))] + + [tp-group-box (instantiate group-box-panel% () + (label (string-constant teachpacks)) + (parent parent) + (alignment '(center top)))] + [tp-panel (new vertical-panel% + [parent tp-group-box] + [alignment '(center center)] + [stretchable-width #f] + [stretchable-height #f])] + + [case-sensitive (make-object check-box% + (string-constant case-sensitive-label) + input-panel + void)] + [output-style (make-object radio-box% + (string-constant output-style-label) + (if accept-quasiquote? + (list (string-constant constructor-printing-style) + (string-constant quasiquote-printing-style) + (string-constant write-printing-style)) + (list (string-constant constructor-printing-style) + (string-constant write-printing-style))) + output-panel + void)] + [writing-style (make-object radio-box% + "write-Ausgabe" + (list "explizit" + "Datum") + output-panel + void)] + [fraction-style + (make-object radio-box% (string-constant fraction-style) + (list (string-constant use-mixed-fractions) + (string-constant use-repeating-decimals)) + output-panel + void)] + [show-sharing #f] + [insert-newlines (make-object check-box% + (string-constant use-pretty-printer-label) + output-panel + void)] + #; + [tracing (new check-box% + (parent output-panel) + (label sc-tracing) + (callback void))] + + [tps '()]) + + (when allow-sharing-config? + (set! show-sharing + (instantiate check-box% () + (parent output-panel) + (label (string-constant sharing-printing-label)) + (callback void)))) + + ;; set the characteristics of the GUI + (send _parent set-alignment 'center 'center) + (send parent stretchable-height #f) + (send parent stretchable-width #f) + (send parent set-alignment 'center 'center) + + (case-lambda + [() + (make-deinprogramm-lang-settings + (send case-sensitive get-value) + (if accept-quasiquote? + (case (send output-style get-selection) + [(0) 'constructor] + [(1) 'quasiquote] + [(2) 'write]) + (case (send output-style get-selection) + [(0) 'constructor] + [(1) 'write])) + (case (send fraction-style get-selection) + [(0) 'mixed-fraction] + [(1) 'repeating-decimal]) + (and allow-sharing-config? (send show-sharing get-value)) + (send insert-newlines get-value) + 'none + (case (send writing-style get-selection) + [(0) 'explicit] + [(1) 'datum]) + #f ;; (send tracing get-value) -- disabled tracing + tps)] + [(settings) + (send case-sensitive set-value (drscheme:language:simple-settings-case-sensitive settings)) + (send output-style set-selection + (if accept-quasiquote? + (case (drscheme:language:simple-settings-printing-style settings) + [(constructor) 0] + [(quasiquote) 1] + [(write) 2] + [(print) 2]) + (case (drscheme:language:simple-settings-printing-style settings) + [(constructor) 0] + [(quasiquote) 0] + [(write) 1] + [(print) 1]))) + (send writing-style set-selection + (case (deinprogramm-lang-settings-writing-style settings) + [(explicit) 0] + [(datum) 1])) + (send fraction-style set-selection + (case (drscheme:language:simple-settings-fraction-style settings) + [(mixed-fraction) 0] + [(repeating-decimal) 1])) + (when allow-sharing-config? + (send show-sharing set-value (drscheme:language:simple-settings-show-sharing settings))) + (send insert-newlines set-value + (drscheme:language:simple-settings-insert-newlines settings)) + (set! tps (deinprogramm-lang-settings-teachpacks settings)) + (send tp-panel change-children (lambda (l) '())) + (if (null? tps) + (new message% + [parent tp-panel] + [label (string-constant teachpacks-none)]) + (for-each + (lambda (tp) (new message% + [parent tp-panel] + [label (format "~s" tp)])) + tps)) + ;; disabled tracing + #; (send tracing set-value (htdp-lang-settings-tracing? settings)) + (void)]))) + + (define simple-deinprogramm-language% + (class* drscheme:language:simple-module-based-language% (deinprogramm-language<%>) + (init-field sharing-printing + abbreviate-cons-as-list + allow-sharing? + manual + reader-module + (use-function-output-syntax? #f) + (accept-quasiquote? #t) + (read-accept-dot #t) ;; #### should only be this in advanced mode + (style-delta #f)) + (define/public (get-sharing-printing) sharing-printing) + (define/public (get-abbreviate-cons-as-list) abbreviate-cons-as-list) + (define/public (get-allow-sharing?) allow-sharing?) + (define/public (get-manual) manual) + (define/public (get-use-function-output-syntax?) use-function-output-syntax?) + (define/public (get-accept-quasiquote?) accept-quasiquote?) + (define/public (get-read-accept-dot) read-accept-dot) + ;(define/override (get-one-line-summary) one-line-summary) + (define/public (get-deinprogramm-style-delta) style-delta) + + (super-instantiate () + (language-url "http://www.deinprogramm.de/dmda/")))) + + (define (language-extension %) + (class % + (inherit get-manual) + + (define/override (extra-repl-information settings port) + (define welcome (drscheme:rep:get-welcome-delta)) + (define (go str sd) + (let* ([s (make-object string-snip% str)] + [sl (editor:get-standard-style-list)] + [std (send sl find-named-style "Standard")] + [style (send sl find-or-create-style std sd)]) + (send s set-style style) + (write-special s port))) + + (define tps (deinprogramm-lang-settings-teachpacks settings)) + + (unless (null? tps) + (go "Teachpack" welcome) + (cond + [(= 1 (length tps)) + (go ": " welcome) + (go (cadr (car tps)) (drscheme:rep:get-dark-green-delta))] + [(= 2 (length tps)) + (go "s: " welcome) + (go (cadr (car tps)) (drscheme:rep:get-dark-green-delta)) + (go " und " welcome) + (go (cadr (cadr tps)) (drscheme:rep:get-dark-green-delta))] + [else + (go "s: " welcome) + (go (cadr (car tps)) (drscheme:rep:get-dark-green-delta)) + (let loop ([these-tps (cdr tps)]) + (cond + [(null? (cdr these-tps)) + (go " und " welcome) + (go (cadr (car these-tps)) (drscheme:rep:get-dark-green-delta))] + [else + (go ", " welcome) + (go (cadr (car these-tps)) (drscheme:rep:get-dark-green-delta)) + (loop (cdr these-tps))]))]) + (go "." welcome) + (newline port))) + + (inherit get-module get-transformer-module get-init-code + use-namespace-require/copy?) + (define/override (create-executable setting parent program-filename) + (let ([dist-filename + (drscheme:language:put-executable + parent program-filename + 'distribution + #t + (string-constant save-a-mred-distribution))]) + (when dist-filename + (drscheme:language:create-distribution-for-executable + dist-filename + #t + (lambda (exe-name) + (create-embedding-executable + exe-name + #:modules `((#f ,program-filename)) + #:cmdline `("-l" + "scheme/base" + "-e" + ,(format "~s" `(#%require ',(filename->require-symbol program-filename)))) + #:src-filter + (lambda (path) (cannot-compile? path)) + #:get-extra-imports + (lambda (path cm) + (call-with-input-file path + (lambda (port) + (cond + [(is-wxme-stream? port) + (let-values ([(snip-class-names data-class-names) + (extract-used-classes port)]) + (list* + '(lib "wxme/read.ss") + '(lib "mred/mred.ss") + reader-module + (filter + values + (map (lambda (x) (string->lib-path x #t)) + (append + snip-class-names + data-class-names)))))] + [else + '()])))) + #:mred? #t)))))) + + (define/private (filename->require-symbol fn) + (let-values ([(base name dir) (split-path fn)]) + (string->symbol + (path->string + (path-replace-suffix name #""))))) + + (define/private (get-export-names sexp) + (let* ([sym-name ((current-module-name-resolver) sexp #f #f)] + [no-ext-name (substring (symbol->string sym-name) + 1 + (string-length (symbol->string sym-name)))] + [full-name + (cond + [(file-exists? (string-append no-ext-name ".ss")) + (string-append no-ext-name ".ss")] + [(file-exists? (string-append no-ext-name ".scm")) + (string-append no-ext-name ".scm")] + [(file-exists? no-ext-name) + no-ext-name] + [else (error 'deinprogramm-lang.ss "could not find language filename ~s" no-ext-name)])] + [base-dir (let-values ([(base _1 _2) (split-path full-name)]) base)] + [stx + (call-with-input-file full-name + (lambda (port) + (read-syntax full-name port)))] + [code + (parameterize ([current-load-relative-directory base-dir] + [current-directory base-dir]) + (expand stx))] + [find-name + (lambda (p) + (cond + [(symbol? p) p] + [(and (pair? p) (pair? (cdr p))) + (cadr p)] + [else (car p)]))]) + (append + (map find-name (syntax-property code 'module-variable-provides)) + (map find-name (syntax-property code 'module-syntax-provides))))) + + (define/private (symbol-append x y) + (string->symbol + (string-append + (symbol->string x) + (symbol->string y)))) + + (inherit get-deinprogramm-style-delta) + (define/override (get-style-delta) + (get-deinprogramm-style-delta)) + + (inherit get-reader set-printing-parameters) + + (define/override (front-end/complete-program port settings) + (expand-teaching-program port + (get-reader) + (get-module) + (deinprogramm-lang-settings-teachpacks settings) + (drscheme:rep:current-rep) + '#%deinprogramm)) + + ;; DeinProgramm addition: needed for test boxes; see the code + ;; in collects/drscheme/private/language.ss + (define/override (front-end/interaction port settings) + (let ((reader (get-reader))) + (lambda () + (reader (object-name port) port)))) + + (define/augment (capability-value key) + (case key + [(drscheme:teachpack-menu-items) deinprogramm-teachpack-callbacks] + [(drscheme:special:insert-lambda) #f] + [else (inner (drscheme:language:get-capability-default key) + capability-value + key)])) + + (define deinprogramm-teachpack-callbacks + (drscheme:unit:make-teachpack-callbacks + (lambda (settings) + (map cadr (deinprogramm-lang-settings-teachpacks settings))) + (lambda (settings parent) + (let ([teachpack (get-teachpack-from-user parent)]) + (if teachpack + (let ([old-tps (deinprogramm-lang-settings-teachpacks settings)]) + (if (member teachpack old-tps) + (begin + (message-box (string-constant drscheme) + (format (string-constant already-added-teachpack) + (cadr teachpack))) + settings) + + (let ([new-tps (append old-tps (list teachpack))]) + (preferences:set 'drscheme:deinprogramm:last-set-teachpacks new-tps) + (make-deinprogramm-lang-settings + (drscheme:language:simple-settings-case-sensitive settings) + (drscheme:language:simple-settings-printing-style settings) + (drscheme:language:simple-settings-fraction-style settings) + (drscheme:language:simple-settings-show-sharing settings) + (drscheme:language:simple-settings-insert-newlines settings) + (drscheme:language:simple-settings-annotations settings) + (deinprogramm-lang-settings-writing-style settings) + (deinprogramm-lang-settings-tracing? settings) + new-tps)))) + settings))) + (lambda (settings name) + (let ([new-tps (filter (lambda (x) (not (equal? (cadr x) name))) + (deinprogramm-lang-settings-teachpacks settings))]) + (preferences:set 'drscheme:deinprogramm:last-set-teachpacks new-tps) + (make-deinprogramm-lang-settings + (drscheme:language:simple-settings-case-sensitive settings) + (drscheme:language:simple-settings-printing-style settings) + (drscheme:language:simple-settings-fraction-style settings) + (drscheme:language:simple-settings-show-sharing settings) + (drscheme:language:simple-settings-insert-newlines settings) + (drscheme:language:simple-settings-annotations settings) + (deinprogramm-lang-settings-writing-style settings) + (deinprogramm-lang-settings-tracing? settings) + new-tps))) + (lambda (settings) + (preferences:set 'drscheme:deinprogramm:last-set-teachpacks '()) + (make-deinprogramm-lang-settings + (drscheme:language:simple-settings-case-sensitive settings) + (drscheme:language:simple-settings-printing-style settings) + (drscheme:language:simple-settings-fraction-style settings) + (drscheme:language:simple-settings-show-sharing settings) + (drscheme:language:simple-settings-insert-newlines settings) + (drscheme:language:simple-settings-annotations settings) + (deinprogramm-lang-settings-writing-style settings) + (deinprogramm-lang-settings-tracing? settings) + '())))) + + (inherit-field reader-module) + (define/override (get-reader-module) reader-module) + (define/override (get-metadata modname settings) + (string-append + ";; Die ersten drei Zeilen dieser Datei wurden von DrScheme eingefügt. Sie enthalten Metadaten\n" + ";; über die Sprachebene dieser Datei in einer Form, die DrScheme verarbeiten kann.\n" + (format "#reader~s~s\n" + reader-module + `((modname ,modname) + (read-case-sensitive ,(drscheme:language:simple-settings-case-sensitive settings)) + (teachpacks ,(deinprogramm-lang-settings-teachpacks settings)) + (deinprogramm-settings ,(deinprogramm-lang-settings->vector settings)))))) + + (inherit default-settings) + (define/override (metadata->settings metadata) + (let* ([table (metadata->table metadata)] ;; extract the table + [ssv (assoc 'deinprogramm-settings table)]) + (if ssv + (let ([settings-list (vector->list (cadr ssv))]) + (if (equal? (length settings-list) + (procedure-arity make-deinprogramm-lang-settings)) + (apply make-deinprogramm-lang-settings settings-list) + (default-settings))) + (default-settings)))) + + (define/private (metadata->table metadata) + (let ([p (open-input-string metadata)]) + (regexp-match #rx"\n#reader" p) ;; skip to reader + (read p) ;; skip module + (read p))) + + (define/override (get-metadata-lines) 3) + + (super-new))) + + ;; cannot-compile? : path -> boolean + ;; returns #t if the file cannot be compiled, #f otherwise + (define (cannot-compile? path) + (call-with-input-file path + (lambda (port) + (let ([ok-to-compile-names + (map (lambda (x) (format "~s" x)) + '(wxtext + (lib "comment-snip.ss" "framework") + (lib "xml-snipclass.ss" "xml") + (lib "scheme-snipclass.ss" "xml") + (lib "test-case-box-snipclass.ss" "test-suite")))]) + (and (is-wxme-stream? port) + (let-values ([(snip-class-names data-class-names) + (extract-used-classes port)]) + (not (and (andmap + (lambda (used-name) (member used-name ok-to-compile-names)) + snip-class-names) + (andmap + (lambda (used-name) (member used-name ok-to-compile-names)) + data-class-names))))))))) + + (define (get-teachpack-from-user parent) + (define tp-dir (collection-path "teachpack" "deinprogramm")) + (define columns 2) + (define tps (filter + (lambda (x) (file-exists? (build-path tp-dir x))) + (directory-list tp-dir))) + (define sort-order (lambda (x y) (string<=? (path->string x) (path->string y)))) + (define pre-installed-tps (sort tps sort-order)) + (define dlg (new dialog% [parent parent] [label (string-constant drscheme)])) + (define hp (new horizontal-panel% [parent dlg])) + (define answer #f) + (define compiling? #f) + + (define pre-installed-gb (new group-box-panel% + [label (string-constant teachpack-pre-installed)] + [parent hp])) + (define user-installed-gb (new group-box-panel% + [label (string-constant teachpack-user-installed)] + [parent hp])) + + (define pre-installed-lb + (new list-box% + [label #f] + [choices (map path->string pre-installed-tps)] + [stretchable-height #t] + [min-height 300] + [min-width 200] + [callback + (lambda (x evt) + (case (send evt get-event-type) + [(list-box-dclick) (selected pre-installed-lb)] + [else + (clear-selection user-installed-lb) + (update-button)]))] + [parent pre-installed-gb])) + + (define user-installed-lb + (new list-box% + [label #f] + [choices '()] + [stretchable-height #t] + [min-width 200] + [callback + (lambda (x evt) + (case (send evt get-event-type) + [(list-box-dclick) (selected user-installed-lb)] + [else + (clear-selection pre-installed-lb) + (update-button)]))] + [parent user-installed-gb])) + + (define (selected lb) + (unless compiling? + (set! answer (figure-out-answer)) + (send dlg show #f))) + + (define (clear-selection lb) + (for-each + (lambda (x) (send lb select x #f)) + (send lb get-selections))) + + (define add-button (new button% + [parent user-installed-gb] + [label (string-constant add-teachpack-to-list...)] + [callback (lambda (x y) (install-teachpack))])) + + (define (install-teachpack) + (let ([file (get-file (string-constant select-a-teachpack) dlg)]) + (when file + (let-values ([(base name dir) (split-path file)]) + (let ([dest-file (build-path teachpack-installation-dir name)]) + (when (or (not (file-exists? dest-file)) + (equal? 1 + (message-box/custom + (string-constant drscheme) + (format + (string-constant teachpack-already-installed) + (path->string name)) + (string-constant overwrite) + (string-constant cancel) + #f + dlg + '(default=2 caution)))) + (make-directory* teachpack-installation-dir) + (when (file-exists? dest-file) + (delete-file dest-file)) + (copy-file file dest-file) + + ;; compiling the teachpack should be the last thing in this GUI callback + (compile-new-teachpack dest-file))))))) + + (define (compile-new-teachpack filename) + (let-values ([(_1 short-name _2) (split-path filename)]) + (cond + [(cannot-compile? filename) + (post-compilation-gui-cleanup short-name)] + [else + (send compiling-message set-label + (format (string-constant compiling-teachpack) + (path->string short-name))) + (starting-compilation) + (let ([nc (make-custodian)] + [exn #f]) + (let ([t + (parameterize ([current-custodian nc]) + (thread (lambda () + (with-handlers ((exn? (lambda (x) (set! exn x)))) + (parameterize ([read-accept-reader #t] + [current-namespace (make-base-namespace)]) + (compile-file filename))))))]) + (thread + (lambda () + (thread-wait t) + (queue-callback + (lambda () + (cond + [exn + (message-box (string-constant drscheme) + (exn-message exn)) + (delete-file filename) + (update-user-installed-lb)] + [else + (post-compilation-gui-cleanup short-name)]) + (done-compilation) + (send compiling-message set-label "")))))))]))) + + (define (post-compilation-gui-cleanup short-name) + (update-user-installed-lb) + (clear-selection pre-installed-lb) + (send user-installed-lb set-string-selection (path->string short-name))) + + (define (starting-compilation) + (set! compiling? #t) + (update-button) + (send cancel-button enable #f)) + + (define (done-compilation) + (set! compiling? #f) + (update-button) + (send cancel-button enable #t)) + + (define (update-user-installed-lb) + (let ([files + (if (directory-exists? teachpack-installation-dir) + (map path->string + (filter + (lambda (x) (file-exists? (build-path teachpack-installation-dir x))) + (directory-list teachpack-installation-dir))) + '())]) + (send user-installed-lb set (sort files string<=?)))) + + + (define (update-button) + (send ok-button enable + (and (not compiling?) + (or (pair? (send user-installed-lb get-selections)) + (pair? (send pre-installed-lb get-selections)))))) + + (define button-panel (new horizontal-panel% + [parent dlg] + [alignment '(right center)] + [stretchable-height #f])) + (define compiling-message (new message% [parent button-panel] [label ""] [stretchable-width #t])) + (define-values (ok-button cancel-button) + (gui-utils:ok/cancel-buttons button-panel + (lambda (b e) + (set! answer (figure-out-answer)) + (send dlg show #f)) + (lambda (b e) + (send dlg show #f)) + (string-constant ok) (string-constant cancel))) + + (define (figure-out-answer) + (cond + [(send pre-installed-lb get-selection) + => + (lambda (i) `(lib ,(send pre-installed-lb get-string i) + "teachpack" + "deinprogramm"))] + [(send user-installed-lb get-selection) + => + (lambda (i) `(lib ,(send user-installed-lb get-string i) + ,user-installed-teachpacks-collection))] + [else (error 'figure-out-answer "no selection!")])) + + + (send ok-button enable #f) + (update-user-installed-lb) + + (send dlg show #t) + answer) + + (define (stepper-settings-language %) + (class* % (stepper-language<%>) + (init-field stepper:supported) + (define/override (stepper:supported?) stepper:supported) + (define/override (stepper:render-to-sexp val settings language-level) + (parameterize ([pc:current-print-convert-hook (make-print-convert-hook settings)]) + (set-print-settings + language-level + settings + (lambda () + (stepper-convert-value val settings))))) + + (super-new))) + + (define (debugger-settings-language %) + (class* % (debugger-language<%>) + (init-field [debugger:supported #f]) + (define/override (debugger:supported?) debugger:supported) + (super-new))) + + ;; make-print-convert-hook: + ;; simple-settings -> (TST (TST -> TST) (TST -> TST) -> TST) + ;; this code copied from various locations in language.ss and rep.ss + (define (make-print-convert-hook simple-settings) + (lambda (exp basic-convert sub-convert) + (cond + [(is-a? exp snip%) + (send exp copy)] + [else (basic-convert exp)]))) + + ;; filter/hide-ids : syntax[list] -> listof syntax + (define (filter/hide-ids ids) + ;; When a `define-values' or `define-syntax' declaration + ;; is macro-generated, if the defined name also originates + ;; from a macro, then the name is hidden to anything + ;; that wasn't generated by the same macro invocation. This + ;; hiding relies on renaming at the symbol level, and it's + ;; exposed by the fact that `syntax-e' of the identifier + ;; returns a different name than `identifier-binding'. + (filter + (lambda (id) + (let ([ib (identifier-binding id)]) + ;; ib should always be a 4-elem list, but + ;; check, just in case: + (or (not (pair? ib)) + (eq? (syntax-e id) + (cadr ib))))) + (syntax->list ids))) + + + ; + ; + ; + ; + ; + ; ; + ; ;;; ; ; ; ; ;;; ; ; ;;;; ; ; ;;; ;;; ;;; + ; ; ; ;; ;; ; ; ;; ; ;; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;;;;;; ; ; ; ; ; ; ; ;;;; ; ;;;;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;;;; ; ; ;;; ; ;; ; ;;;;; ;;; ;;;; + ; + ; + ; + + + + + ;; cm-key : symbol + ;; the key used to put information on the continuation + ;; DeinProgramm change: contract-test-engine.ss knows about this + (define cm-key 'deinprogramm-teaching-languages-continuation-mark-key) + + (define mf-note + (let ([bitmap + (make-object bitmap% + (build-path (collection-path "icons") "mf.gif"))]) + (and (send bitmap ok?) + (make-object image-snip% bitmap)))) + + ;; teaching-languages-error-display-handler : + ;; (string (union TST exn) -> void) -> string exn -> void + ;; adds in the bug icon, if there are contexts to display + (define (teaching-languages-error-display-handler msg exn) + + (if (exn? exn) + (display (exn-message exn) (current-error-port)) + (fprintf (current-error-port) "uncaught exception: ~e" exn)) + (fprintf (current-error-port) "\n") + + ;; need to flush here so that error annotations inserted in next line + ;; don't get erased if this output were to happen after the insertion + (flush-output (current-error-port)) + + (let ([rep (drscheme:rep:current-rep)]) + (when (and (is-a? rep drscheme:rep:text<%>) + (eq? (send rep get-err-port) (current-error-port))) + (let ([to-highlight + (cond + [(exn:srclocs? exn) + ((exn:srclocs-accessor exn) exn)] + [(exn? exn) + (let ([cms (continuation-mark-set->list (exn-continuation-marks exn) cm-key)]) + (cond + ((not cms) '()) + ((findf (lambda (mark) + (and mark + (or (path? (car mark)) + (symbol? (car mark))))) + cms) + => (lambda (mark) + (apply (lambda (source line col pos span) + (list (make-srcloc source line col pos span))) + mark))) + (else '())))] + [else '()])]) + + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (lambda () + ;; need to make sure that the user's eventspace is still the same + ;; and still running here? + (send rep highlight-errors to-highlight #f)))))))) + + ;; with-mark : syntax syntax -> syntax + ;; a member of stacktrace-imports^ + ;; guarantees that the continuation marks associated with cm-key are + ;; members of the debug-source type + (define (with-mark source-stx expr) + (let ([source (syntax-source source-stx)] + [line (syntax-line source-stx)] + [col (syntax-column source-stx)] + [start-position (syntax-position source-stx)] + [span (syntax-span source-stx)]) + (if (and (or (symbol? source) (path? source)) + (number? start-position) + (number? span)) + (with-syntax ([expr expr] + [mark (list source line col start-position span)] + [cm-key cm-key]) + #`(with-continuation-mark 'cm-key + 'mark + expr)) + expr))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; profiling infrastructure. Not used. + ;; + + (define profile-key (gensym)) + (define (profiling-enabled) #f) + (define (initialize-profile-point . x) (void)) + (define (register-profile-start . x) #f) + (define (register-profile-done . x) (void)) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; test coverage + ;; + + (define test-coverage-enabled (make-parameter #t)) + (define current-test-coverage-info (make-thread-cell #f)) + + (define (initialize-test-coverage-point key expr) + (unless (thread-cell-ref current-test-coverage-info) + (let ([ht (make-hasheq)]) + (thread-cell-set! current-test-coverage-info ht) + (let ([rep (drscheme:rep:current-rep)]) + (when rep + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (lambda () + (let ([on-sd (make-object style-delta%)] + [off-sd (make-object style-delta%)]) + (cond + [(preferences:get 'framework:white-on-black?) + (send on-sd set-delta-foreground "white") + (send off-sd set-delta-background "lightblue") + (send off-sd set-delta-foreground "black")] + [else + (send on-sd set-delta-foreground "black") + (send off-sd set-delta-background "lightblue") + (send off-sd set-delta-foreground "black")]) + (send rep set-test-coverage-info ht on-sd off-sd #f))))))))) + (let ([ht (thread-cell-ref current-test-coverage-info)]) + (when ht + (hash-set! ht key (mcons #f expr))))) + + (define (test-covered key) + (let ([ht (thread-cell-ref current-test-coverage-info)]) + (when ht + (let ([v (hash-ref ht key)]) + (set-mcar! v #t))))) + + (define-values/invoke-unit et:stacktrace@ + (import et:stacktrace-imports^) (export (prefix et: et:stacktrace^))) + + (define calltrace-key #`(quote #,(gensym 'drscheme-calltrace-key))) + + (define (print-call-trace inferred-name original? src args improper? depth) + (when inferred-name + (let ([name (cond + [(identifier? inferred-name) (syntax-e inferred-name)] + [else (object-name inferred-name)])] + [rep (drscheme:rep:current-rep)]) + (when (and name rep) + (let ([canvas (send rep get-canvas)]) + (when canvas + (let* ([frame (send canvas get-top-level-window)] + [tab (send frame get-current-tab)]) + (when (is-a? tab tab-tracing<%>) + (let ([sp (open-output-string)]) + (let loop ([i depth]) + (unless (zero? i) + (display " " sp) + (loop (- i 1)))) + (fprintf sp "(") + (fprintf sp "~a" name) + (let loop ([args args]) + (cond + [(null? args) (void)] + [(and (null? (cdr args)) improper?) + (fprintf sp " . ") + (fprintf sp "~v" (car args))] + [else + (let ([arg (car args)]) + (fprintf sp " ") + (fprintf sp "~v" arg)) + (loop (cdr args))])) + (fprintf sp ")") + (let ([sema (make-semaphore)]) + ;; Disable breaks, so an exn handler can't + ;; grab the DrScheme eventspacae: + (parameterize-break #f + ;; Queue callback to write trace line --- + ;; low priority, so that infinite loops don't stop the user + ;; from clicking "Break" + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (lambda () + (send tab tracing:add-line (get-output-string sp)) + (semaphore-post sema)) + #f))) + ;; Wait for the line to get written, so that the + ;; trace output doesn't get too far behind (which + ;; matters, again, for infinite loops) + (semaphore-wait sema))))))))))) + + (define-values/invoke-unit tr:stacktrace@ + (import tr:stacktrace-imports^) (export (prefix tr: tr:stacktrace^))) + + ;; add-annotation : boolean (sexp -> value) -> sexp -> value + ;; adds debugging and test coverage information to `sexp' and calls `oe' + (define (add-annotation tracing? oe) + (let ([teaching-language-eval-handler + (lambda (exp) + (let* ([is-compiled? (compiled-expression? (if (syntax? exp) (syntax-e exp) exp))] + [annotated + (if is-compiled? + exp + (let* ([et-annotated (et:annotate-top (expand exp) + (namespace-base-phase))] + [tr-annotated + (if tracing? + (tr:annotate (expand et-annotated)) + et-annotated)]) + tr-annotated))]) + (oe annotated)))]) + teaching-language-eval-handler)) + + (define tab-tracing-mixin + (mixin (drscheme:unit:tab<%> drscheme:rep:context<%>) (tab-tracing<%>) + (inherit get-frame) + + (define tracing-visible? #f) + (define/public (set-tracing-visible? v?) (set! tracing-visible? v?)) + (define/public (get-tracing-visible?) tracing-visible?) + + (define/augment (clear-annotations) + (tracing:reset) + (inner (void) clear-annotations)) + + (define any-results? #f) + (define/public (get-any-results?) any-results?) + (define/public (tracing:reset) + (set! any-results? #f) + (send show-tracing-text lock #f) + (send show-tracing-text erase) + (send show-tracing-text auto-wrap #t) + (send show-tracing-text insert sc-tracing-nothing-to-show) + (send show-tracing-text lock #t)) + + (define show-tracing-text (new text:hide-caret/selection%)) + (define/public (get-tracing-text) show-tracing-text) + (send show-tracing-text lock #t) + + (define/public (tracing:add-line s) + (let ([old-any? any-results?]) + (set! any-results? #t) + (unless old-any? + (send (get-frame) show-tracing)) + (send show-tracing-text begin-edit-sequence) + (send show-tracing-text lock #f) + (unless old-any? + (send show-tracing-text erase) + (send show-tracing-text auto-wrap #f)) + (let ([insert + (lambda (s) + (send show-tracing-text insert s (send show-tracing-text last-position) 'same #f))]) + (cond + [(<= (string-length s) ellipses-cutoff) + (insert s) + (insert "\n")] + [else + (insert (substring s 0 ellipses-cutoff)) + (insert " ") + (let ([ell-start (send show-tracing-text last-position)]) + (insert "...") + (let ([ell-end (send show-tracing-text last-position)]) + (let ([para (send show-tracing-text last-paragraph)]) + (insert "\n") + (send show-tracing-text change-style clickback-delta ell-start ell-end) + (send show-tracing-text set-clickback ell-start ell-end + (lambda (t x y) + (send show-tracing-text begin-edit-sequence) + (send show-tracing-text lock #f) + (let ([line-start (send show-tracing-text paragraph-start-position para)] + [line-end (send show-tracing-text paragraph-end-position para)]) + (send show-tracing-text delete line-start line-end #f) + (send show-tracing-text insert s line-start 'same #f)) + (send show-tracing-text lock #t) + (send show-tracing-text end-edit-sequence))))))])) + (send show-tracing-text lock #t) + (send show-tracing-text end-edit-sequence))) + + (super-new))) + + + (define frame-tracing-mixin + (mixin (drscheme:frame:<%> drscheme:unit:frame<%>) () + (inherit get-current-tab) + (define show-tracing-menu-item #f) + (define tracing-visible? #f) + + (define/augment (on-tab-change old new) + (inner (void) on-tab-change old new) + (send show-tracing-canvas set-editor (send new get-tracing-text)) + (cond + [(eq? tracing-visible? (send new get-tracing-visible?)) + (void)] + [(send new get-tracing-visible?) + (show-tracing)] + [else + (hide-tracing)])) + + (define/override (add-show-menu-items show-menu) + (super add-show-menu-items show-menu) + (set! show-tracing-menu-item + (new menu-item% + (parent show-menu) + (label sc-show-tracing-window) + (callback (lambda (x y) (toggle-tracing)))))) + + (define/public (show-tracing) + (set! tracing-visible? #t) + (send show-tracing-menu-item set-label sc-hide-tracing-window) + (send dragable-parent begin-container-sequence) + (send dragable-parent change-children + (lambda (l) + (let ([without (remq show-tracing-canvas l)]) + (append without (list show-tracing-canvas))))) + (send dragable-parent set-percentages '(3/4 1/4)) + (send dragable-parent end-container-sequence)) + + (define/private (hide-tracing) + (set! tracing-visible? #f) + (send show-tracing-menu-item set-label sc-show-tracing-window) + (send dragable-parent change-children + (lambda (l) + (remq show-tracing-canvas l)))) + + (define/private (toggle-tracing) + (if tracing-visible? + (hide-tracing) + (show-tracing))) + + (define dragable-parent #f) + (define show-tracing-parent-panel #f) + (define show-tracing-canvas #f) + + (define/override (make-root-area-container cls parent) + (set! dragable-parent (super make-root-area-container panel:horizontal-dragable% parent)) + (let ([root (make-object cls dragable-parent)]) + (set! show-tracing-canvas (new editor-canvas% + (parent dragable-parent) + (editor (send (get-current-tab) get-tracing-text)))) + (send dragable-parent change-children (lambda (l) (remq show-tracing-canvas l))) + root)) + + (super-new))) + + (define clickback-delta (make-object style-delta%)) + (send clickback-delta set-delta-foreground "BLUE") + (send clickback-delta set-delta 'change-underline #t) + + +; +; +; +; ; ; ; ; +; ; ; ; +; ; ; ; ; ; ; ; +; ; ;; ; ; ;;;; ; ;;;; ;;; ; ; ;;;; ;;; ;; ; ;;; ;;;; ; ;; ;;; ; ; +; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ;; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ;;;;;; ; ; ; ;;;;;; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; +; ; ;; ;; ; ;; ; ;; ;;;;; ; ; ;; ;;; ;; ; ;;;; ;; ; ; ;;;; ; +; ; ; +; ; ; ; +; ; ;;;; + + + ;; add-deinprogramm-language : (instanceof deinprogramm-language<%>) -> void + (define (add-deinprogramm-language o) + (drscheme:language-configuration:add-language o)) + + (define (phase1) (void)) + + ;; phase2 : -> void + (define (phase2) + (define (make-deinprogramm-language% printing-style writing-style) + (debugger-settings-language + (stepper-settings-language + ((drscheme:language:get-default-mixin) + (language-extension + (drscheme:language:module-based-language->language-mixin + (module-based-language-extension + printing-style writing-style + (drscheme:language:simple-module-based-language->module-based-language-mixin + simple-deinprogramm-language%)))))))) + + (add-deinprogramm-language + (instantiate (make-deinprogramm-language% 'write 'explicit) () + (one-line-summary "Die Macht der Abstraktion - Anfänger") + (module '(lib "deinprogramm/DMdA-beginner.ss")) + (manual #"DMdA-beginner") + (language-position (list (string-constant teaching-languages) + "DeinProgramm" "Die Macht der Abstraktion - Anfänger")) + (language-id "DMdA:beginner") + (language-numbers '(-500 -300 3)) + (sharing-printing #t) + (abbreviate-cons-as-list #t) + (allow-sharing? #t) + (reader-module '(lib "DMdA-beginner-reader.ss" "deinprogramm")) + (stepper:supported #t))) + + (add-deinprogramm-language + (instantiate (make-deinprogramm-language% 'write 'explicit) () + (one-line-summary "Die Macht der Abstraktion") + (module '(lib "deinprogramm/DMdA-vanilla.ss")) + (manual #"DMdA-vanilla") + (language-position (list (string-constant teaching-languages) + "DeinProgramm" "Die Macht der Abstraktion")) + (language-id "DMdA:vanilla") + (language-numbers '(-500 -300 4)) + (sharing-printing #t) + (abbreviate-cons-as-list #t) + (allow-sharing? #t) + (reader-module '(lib "DMdA-vanilla-reader.ss" "deinprogramm")) + (stepper:supported #t))) + + (add-deinprogramm-language + (instantiate (make-deinprogramm-language% 'write 'explicit) () + (one-line-summary "Die Macht der Abstraktion mit Zuweisungen") + (module '(lib "deinprogramm/DMdA-assignments.ss")) + (manual #"DMdA-assignments") + (language-position (list (string-constant teaching-languages) + "DeinProgramm" "Die Macht der Abstraktion mit Zuweisungen")) + (language-id "DMdA:assignments") + (language-numbers '(-500 -300 5)) + (sharing-printing #f) + (abbreviate-cons-as-list #t) + (allow-sharing? #t) + (reader-module '(lib "DMdA-assignments-reader.ss" "deinprogramm")) + (stepper:supported #f) + (debugger:supported #t))) + + (add-deinprogramm-language + (instantiate (make-deinprogramm-language% 'write 'datum) () + (one-line-summary "Die Macht der Abstraktion - fortgeschritten") + (module '(lib "deinprogramm/DMdA-advanced.ss")) + (manual #"DMdA-advanced") + (language-position (list (string-constant teaching-languages) + "DeinProgramm" "Die Macht der Abstraktion - fortgeschritten")) + (language-id "DMdA:advanced") + (language-numbers '(-500 -300 6)) + (sharing-printing #f) + (abbreviate-cons-as-list #t) + (allow-sharing? #t) + (reader-module '(lib "DMdA-advanced-reader.ss" "deinprogramm")) + (stepper:supported #f) + (debugger:supported #t))) + + ;; #### these bomb: + ;(drscheme:get/extend:extend-unit-frame frame-tracing-mixin) + ;(drscheme:get/extend:extend-tab tab-tracing-mixin) + ))) diff --git a/collects/deinprogramm/deinprogramm-struct.ss b/collects/deinprogramm/deinprogramm-struct.ss new file mode 100644 index 0000000000..28fa75ec59 --- /dev/null +++ b/collects/deinprogramm/deinprogramm-struct.ss @@ -0,0 +1,6 @@ +#lang scheme/base + (provide prop:deinprogramm-struct + deinprogramm-struct?) + + (define-values (prop:deinprogramm-struct deinprogramm-struct? deinprogramm-struct-ref) + (make-struct-type-property 'deinprogramm-struct)) diff --git a/collects/deinprogramm/image.ss b/collects/deinprogramm/image.ss new file mode 100644 index 0000000000..a63b4550ef --- /dev/null +++ b/collects/deinprogramm/image.ss @@ -0,0 +1,868 @@ +#lang scheme/base + +#| + +The test suite for this code is in +.../deinprogramm-test/image.ss + +|# + +(require mred + mzlib/class + mrlib/cache-image-snip + mzlib/math + lang/prim + lang/posn + lang/private/imageeq + htdp/error + deinprogramm/contract/contract-syntax + (only-in deinprogramm/DMdA integer natural)) + +(provide ; #### -primitives doesn't work for us + image? + image-width + image-height + + empty-image + + overlay + above + beside + + clip + pad + + rectangle + circle + ellipse + triangle + line + text + + image-inside? + find-image + + image->color-list + color-list->image + + image->alpha-color-list + alpha-color-list->image + + image-color? + make-color + color-red + color-green + color-blue + color? + make-alpha-color + alpha-color-alpha + alpha-color-red + alpha-color-green + alpha-color-blue + alpha-color? + + octet rgb-color mode image image-color + h-place v-place h-mode v-mode) + +;; ---------------------------------------- + +(define (color-list? l) + (and (list? l) (andmap image-color? l))) +(define (alpha-color-list? l) + (and (list? l) (andmap alpha-color? l))) + +(define-struct color (red green blue) #:inspector (make-inspector)) +(define-struct alpha-color (alpha red green blue) #:inspector (make-inspector)) + +;; ---------------------------------------- + +(define (check name p? v desc arg-posn) (check-arg name (p? v) desc arg-posn v)) + +(define (check-coordinate name val arg-posn) (check name finite-real? val "real" arg-posn)) +(define (check-integer-coordinate name val arg-posn) (check name nii? val "integer" arg-posn)) +(define (check-size name val arg-posn) (check name pos-real? val "positive real" arg-posn)) +(define (check-posi-size name val arg-posn) (check name pos-integer? val "positive integer" arg-posn)) +(define (check-size/0 name val arg-posn) (check name nn-real? val "non-negative real" arg-posn)) +(define (check-h-place name val arg-posn) + (check name h-place? val + "non-negative exact integer or horizontal alignment position" + arg-posn)) +(define (check-v-place name val arg-posn) + (check name v-place? val + "non-negative exact integer or vertical alignment position" + arg-posn)) +(define (check-image name val arg-posn) (check name image? val "image" arg-posn)) +(define (check-image-color name val arg-posn) + (let ([simple-check (lambda (x) (or (string? x) (symbol? x) (color? x)))]) + (check name simple-check val "image-color" arg-posn) + (unless (image-color? val) + (error name "~e is not a valid color name" val)))) +(define (check-mode name val arg-posn) (check name mode? val mode-str arg-posn)) + +(define (pos-real? i) (and (real? i) (positive? i))) +(define (pos-integer? i) (and (integer? i) (positive? i))) +(define (nn-real? i) (and (real? i) (or (zero? i) (positive? i)))) +(define (nii? x) (and (integer? x) (not (= x +inf.0)) (not (= x -inf.0)))) + +(define (finite-real? x) (and (real? x) (not (= x +inf.0)) (not (= x -inf.0)))) + +(define (check-sizes who w h) + (unless (and (< 0 w 10000) (< 0 h 10000)) + (error (format "cannot make ~a x ~a image" w h)))) + +(define (mode? x) + (member x '(solid "solid" outline "outline"))) + +(define mode-str "'solid \"solid\" 'outline or \"outline\"") + +(define (mode->brush-symbol m) + (cond + [(member m '(solid "solid")) + 'solid] + [(member m '(outline "outline")) + 'transparent])) + +(define (mode->pen-symbol m) + (cond + [(member m '(solid "solid")) 'transparent] + [(member m '(outline "outline")) 'solid])) + +(define (h-place? x) + (or (nn-real? x) + (h-mode? x))) + +(define (v-place? x) + (or (nn-real? x) + (v-mode? x))) + +(define (h-mode? x) + (member x '(left "left" right "right" "center"))) + +(define (v-mode? x) + (member x '(top "top" bottom "bottom" center "center"))) + +(define (make-color% c) + (cond + [(string? c) (send the-color-database find-color c)] + [(symbol? c) (send the-color-database find-color (symbol->string c))] + [(color? c) (make-object color% + (color-red c) + (color-green c) + (color-blue c))] + [else #f])) + +(define (image-color? c) + (cond + [(color? c) #t] + [(string? c) (and (send the-color-database find-color c) #t)] + [(symbol? c) (and (send the-color-database find-color (symbol->string c)) #t)] + [else #f])) + +(define (image-width a) + (check-image 'image-width a "first") + (let-values ([(w h) (snip-size a)]) + (inexact->exact (ceiling w)))) + +(define (image-height a) + (check-image 'image-height a "first") + (let-values ([(w h) (snip-size a)]) + (inexact->exact (ceiling h)))) + +(define (overlay a b h-place v-place) + (overlay-helper 'overlay a b h-place v-place)) + +(define (overlay-helper name a b h-place v-place) + (check-image name a "first") + (check-image name b "second") + (check-h-place name h-place "third") + (check-v-place name v-place "fourth") + (let ((dx (h-place->delta-x h-place a b)) + (dy (v-place->delta-y v-place a b))) + (real-overlay name + a + (inexact->exact (floor dx)) + (inexact->exact (floor dy)) + b))) + +(define (h-place->delta-x h-place a b) + (cond + ((real? h-place) (inexact->exact (floor h-place))) + ((member h-place '(left "left")) 0) + ((member h-place '(right "right")) + (- (image-width a) (image-width b))) + ((member h-place '(center "center")) + (- (quotient (image-width a) 2) + (quotient (image-width b) 2))))) + +(define (v-place->delta-y v-place a b) + (cond + ((real? v-place) (inexact->exact (floor v-place))) + ((member v-place '(top "top")) 0) + ((member v-place '(bottom "bottom")) + (- (image-height a) (image-height b))) + ((member v-place '(center "center")) + (- (quotient (image-height a) 2) + (quotient (image-height b) 2))))) + +(define (above a b h-mode) + (overlay-helper 'above a b h-mode (image-height a))) + +(define (beside a b v-mode) + (overlay-helper 'beside a b (image-width a) v-mode)) + +(define (real-overlay name raw-a delta-x delta-y raw-b) + (let ([a (coerce-to-cache-image-snip raw-a)] + [b (coerce-to-cache-image-snip raw-b)]) + (let-values ([(a-w a-h) (snip-size a)] + [(b-w b-h) (snip-size b)]) + (let* ([left (min 0 delta-x)] + [top (min 0 delta-y)] + [right (max (+ delta-x b-w) a-w)] + [bottom (max (+ delta-y b-h) a-h)] + [new-w (inexact->exact (ceiling (- right left)))] + [new-h (inexact->exact (ceiling (- bottom top)))] + [a-dx (inexact->exact (round (- left)))] + [a-dy (inexact->exact (round (- top)))] + [b-dx (inexact->exact (round (- delta-x left)))] + [b-dy (inexact->exact (round (- delta-y top)))] + [combine (lambda (a-f b-f) + (lambda (dc dx dy) + (a-f dc (+ dx a-dx) (+ dy a-dy)) + (b-f dc (+ dx b-dx) (+ dy b-dy))))]) + (check-sizes name new-w new-h) + (new cache-image-snip% + [dc-proc (combine (send a get-dc-proc) + (send b get-dc-proc))] + [argb-proc (combine (send a get-argb-proc) + (send b get-argb-proc))] + [width new-w] + [height new-h] + ;; match what image=? expects, so we don't get false negatives + [px (floor (/ new-w 2))] + [py (floor (/ new-h 2))]))))) + +;; ------------------------------------------------------------ + +(define (clip raw-img delta-w delta-h width height) + (check-image 'clip raw-img "first") + (check-size/0 'clip delta-w "second") + (check-size/0 'clip delta-h "third") + (check-size/0 'clip width "fourth") + (check-size/0 'clip height "fifth") + (let ((delta-w (inexact->exact (floor delta-w))) + (delta-h (inexact->exact (floor delta-h))) + (width (inexact->exact (floor width))) + (height (inexact->exact (floor height)))) + (let ([img (coerce-to-cache-image-snip raw-img)]) + (let-values ([(i-width i-height) (send img get-size)]) + (let* ([dc-proc (send img get-dc-proc)] + [argb-proc (send img get-argb-proc)]) + (new cache-image-snip% + [dc-proc (lambda (dc dx dy) + (let ([clip (send dc get-clipping-region)] + [rgn (make-object region% dc)]) + (send rgn set-rectangle dx dy width height) + (when clip + (send rgn intersect clip)) + (send dc set-clipping-region rgn) + (dc-proc dc (- dx delta-w) (- dy delta-h)) + (send dc set-clipping-region clip)))] + [argb-proc (lambda (argb dx dy) (argb-proc argb (- dx delta-w) (- dy delta-h)))] + [width width] + [height height] + ;; match what image=? expects, so we don't get false negatives + [px (floor (/ width 2))] [py (floor (/ height 2))])))))) + +(define (pad raw-img left right top bottom) + (check-image 'pad raw-img "first") + (check-size/0 'pad left "second") + (check-size/0 'pad right "third") + (check-size/0 'pad top "fourth") + (check-size/0 'pad bottom "fifth") + (let ((left (inexact->exact (floor left))) + (right (inexact->exact (floor right))) + (top (inexact->exact (floor top))) + (bottom (inexact->exact (floor bottom)))) + (let ([img (coerce-to-cache-image-snip raw-img)]) + (let-values ([(i-width i-height) (send img get-size)]) + (let ((width (+ left i-width right)) + (height (+ top i-height bottom))) + (let* ([dc-proc (send img get-dc-proc)] + [argb-proc (send img get-argb-proc)]) + (new cache-image-snip% + [dc-proc (lambda (dc dx dy) + (let ([clip (send dc get-clipping-region)] + [rgn (make-object region% dc)]) + (send rgn set-rectangle dx dy width height) + (when clip + (send rgn intersect clip)) + (send dc set-clipping-region rgn) + (dc-proc dc (+ dx left) (+ dy top)) + (send dc set-clipping-region clip)))] + [argb-proc (lambda (argb dx dy) (argb-proc argb (+ dx left) (+ dy top)))] + [width width] + [height height] + ;; match what image=? expects, so we don't get false negatives + [px (floor (/ width 2))] [py (floor (/ height 2))]))))))) + + +;; ------------------------------------------------------------ + +;; test what happens when the line moves out of the box. +(define (line width height pre-x1 pre-y1 pre-x2 pre-y2 color-in) + (check-size/0 'line width "first") + (check-size/0 'line height "second") + (check-coordinate 'line pre-x1 "third") + (check-coordinate 'line pre-y1 "fourth") + (check-coordinate 'line pre-x2 "fifth") + (check-coordinate 'line pre-y2 "sixth") + (check-image-color 'line color-in "seventh") + (let ((width (inexact->exact (floor width))) + (height (inexact->exact (floor height)))) + (let-values ([(x1 y1 x2 y2) + (if (<= pre-x1 pre-x2) + (values pre-x1 pre-y1 pre-x2 pre-y2) + (values pre-x2 pre-y2 pre-x1 pre-y1))]) + (define do-draw + (lambda (dc dx dy) + (let ([clip (send dc get-clipping-region)] + [rgn (make-object region% dc)]) + (send rgn set-rectangle dx dy width height) + (when clip + (send rgn intersect clip)) + (send dc set-clipping-region rgn) + (send dc draw-line + (+ x1 dx) (+ y1 dy) (+ x2 dx) (+ y2 dy)) + (send dc set-clipping-region clip)))) + + (let ([draw-proc + (make-color-wrapper color-in 'transparent 'solid do-draw)] + [mask-proc + (make-color-wrapper 'black 'transparent 'solid do-draw)]) + (make-simple-cache-image-snip width height draw-proc mask-proc))))) + +(define (text str size color-in) + (check 'text string? str "string" "first") + (check 'text (lambda (x) (and (integer? x) (<= 1 x 255))) size "integer between 1 and 255" "second") + (check-image-color 'text color-in "third") + (cond + [(string=? str "") + (let-values ([(tw th) (get-text-size size "dummyX")]) + (rectangle 0 th 'solid 'black))] + [else + (let ([color (make-color% color-in)]) + (let-values ([(tw th) (get-text-size size str)]) + (let ([draw-proc + (lambda (txt-color mode dc dx dy) + (let ([old-mode (send dc get-text-mode)] + [old-fore (send dc get-text-foreground)] + [old-font (send dc get-font)]) + (send dc set-text-mode mode) + (send dc set-text-foreground txt-color) + (send dc set-font (get-font size)) + (send dc draw-text str dx dy) + (send dc set-text-mode old-mode) + (send dc set-text-foreground old-fore) + (send dc set-font old-font)))]) + (new cache-image-snip% + [dc-proc (lambda (dc dx dy) (draw-proc color 'transparent dc dx dy))] + [argb-proc + (lambda (argb dx dy) + (let ([bm-color + (build-bitmap + (lambda (dc) + (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) + (send dc set-brush (send the-brush-list find-or-create-brush color 'solid)) + (send dc draw-rectangle 0 0 tw th)) + tw + th)] + [bm-mask + (build-bitmap + (lambda (dc) + (draw-proc + (send the-color-database find-color "black") + 'solid dc 0 0)) + tw + th)]) + (overlay-bitmap argb dx dy bm-color bm-mask)))] + [width tw] + [height th] + ;; match what image=? expects, so we don't get false negatives + [px (floor (/ tw 2))] [py (floor (/ th 2))]))))])) + +(define cached-bdc-for-text-size (make-thread-cell #f)) +(define (get-text-size size string) + (unless (thread-cell-ref cached-bdc-for-text-size) + (let* ([bm (make-object bitmap% 1 1)] + [dc (make-object bitmap-dc% bm)]) + (thread-cell-set! cached-bdc-for-text-size dc))) + (let ([dc (thread-cell-ref cached-bdc-for-text-size)]) + (let-values ([(w h _1 _2) (send dc get-text-extent string (get-font size))]) + (values (inexact->exact (ceiling w)) + (inexact->exact (ceiling h)))))) + +(define (get-font size) + (send the-font-list find-or-create-font size + 'default 'normal 'normal #f + (case (system-type) + [(macosx) 'partly-smoothed] + [else 'smoothed]))) + +(define (a-rect/circ do-draw w h color brush pen) + (let* ([dc-proc (make-color-wrapper color brush pen do-draw)] + [mask-proc (make-color-wrapper 'black brush pen do-draw)]) + (make-simple-cache-image-snip w h dc-proc mask-proc))) + +(define (rectangle w h mode color) + (check-size/0 'rectangle w "first") + (check-size/0 'rectangle h "second") + (check-mode 'rectangle mode "third") + (check-image-color 'rectangle color "fourth") + (let ((w (inexact->exact (floor w))) + (h (inexact->exact (floor h)))) + (a-rect/circ (lambda (dc dx dy) (send dc draw-rectangle dx dy w h)) + w h color (mode->brush-symbol mode) (mode->pen-symbol mode)))) + +(define (ellipse w h mode color) + (check-size/0 'ellipse w "first") + (check-size/0 'ellipse h "second") + (check-mode 'ellipse mode "third") + (check-image-color 'ellipse color "fourth") + (let ((w (inexact->exact (floor w))) + (h (inexact->exact (floor h)))) + (a-rect/circ (lambda (dc dx dy) (send dc draw-ellipse dx dy w h)) + w h color (mode->brush-symbol mode) (mode->pen-symbol mode)))) + +(define (circle r mode color) + (check-size/0 'circle r "first") + (check-mode 'circle mode "second") + (check-image-color 'circle color "third") + (let ((r (inexact->exact (floor r)))) + (a-rect/circ (lambda (dc dx dy) (send dc draw-ellipse dx dy (* 2 r) (* 2 r))) + (* 2 r) (* 2 r) color (mode->brush-symbol mode) (mode->pen-symbol mode)))) + +(define (triangle size mode color) + (check 'triangle + (lambda (x) (and (real? x) (< 2 x 10000))) + size + "positive real number bigger than 2" + "first") + (check-mode 'triangle mode "second") + (check-image-color 'triangle color "third") + (let* ([size (inexact->exact (floor size))] + [right (- size 1)] + [bottom (inexact->exact (ceiling (* size (sin (* 2/3 pi)))))] + [points (list (make-object point% 0 bottom) + (make-object point% right bottom) + (make-object point% (/ size 2) 0))]) + (let ([draw (make-color-wrapper + color (mode->brush-symbol mode) 'solid + (lambda (dc dx dy) + (send dc draw-polygon points dx dy)))] + [mask-draw (make-color-wrapper + 'black (mode->brush-symbol mode) 'solid + (lambda (dc dx dy) + (send dc draw-polygon points dx dy)))] + [w size] + [h (+ bottom 1)]) + (make-simple-cache-image-snip w h draw mask-draw)))) + +(define (make-simple-cache-image-snip w h dc-proc mask-proc) + (let ([w (inexact->exact (ceiling w))] + [h (inexact->exact (ceiling h))]) + (let ([argb-proc + (if (or (zero? w) (zero? h)) + void + (lambda (argb-vector dx dy) + (let ([c-bm (build-bitmap (lambda (dc) (dc-proc dc 0 0)) w h)] + [m-bm (build-bitmap (lambda (dc) (mask-proc dc 0 0)) w h)]) + (overlay-bitmap argb-vector dx dy c-bm m-bm))))]) + (new cache-image-snip% + [dc-proc dc-proc] + [argb-proc argb-proc] + [width w] + [height h] + ;; match what image=? expects, so we don't get false negatives + [px (floor (/ w 2))] [py (floor (/ h 2))])))) + +(define (make-color-wrapper color-in brush pen rest) + (let ([color (make-color% color-in)]) + (lambda (dc dx dy) + (let ([old-brush (send dc get-brush)] + [old-pen (send dc get-pen)]) + (send dc set-brush (send the-brush-list find-or-create-brush color brush)) + (send dc set-pen (send the-pen-list find-or-create-pen color 1 pen)) + (rest dc dx dy) + (send dc set-pen old-pen) + (send dc set-brush old-brush))))) + +;; ------------------------------------------------------------ + +(define (image-inside? i a) + (and (locate-image 'image-inside? + (coerce-to-cache-image-snip i) + (coerce-to-cache-image-snip a)) + #t)) + +(define (find-image i a) + (or (locate-image 'find-image + (coerce-to-cache-image-snip i) + (coerce-to-cache-image-snip a)) + (error 'find-image + "the second image does not appear within the first image"))) + +(define (locate-image who i a) + (check-image who i "first") + (check-image who a "second") + (let-values ([(iw ih) (snip-size i)] + [(aw ah) (snip-size a)]) + (and (iw . >= . aw) + (ih . >= . ah) + (let ([i-argb-vector (argb-vector (send i get-argb))] + [a-argb-vector (argb-vector (send a get-argb))]) + (let ([al (let loop ([offset 0]) + (cond + [(= offset (* ah aw 4)) null] + [else (cons (subvector a-argb-vector offset (+ offset (* 4 aw))) + (loop (+ offset (* 4 aw))))]))]) + (let yloop ([dy 0]) + (and (dy . <= . (- ih ah)) + (let xloop ([dx 0]) + (if (dx . <= . (- iw aw)) + (if (let loop ([al al][dd 0]) + (or (null? al) + (and (first-in-second? + i-argb-vector + (car al) + (* 4 (+ (* (+ dy dd) iw) dx))) + (loop (cdr al) (add1 dd))))) + (make-posn dx dy) + (xloop (add1 dx))) + (yloop (add1 dy))))))))))) + +(define (subvector orig i j) + (let ([v (make-vector (- j i) #f)]) + (let loop ([x i]) + (when (< x j) + (vector-set! v (- x i) (vector-ref orig x)) + (loop (+ x 1)))) + v)) +#| +(initial inequalities thanks to Matthew (thanks!!)) + +We know that, for a combination: + m3 = (m1+m2-m1*m2) and + b3 = (m1*b1*(1-m2) + m2*b2)/m3 + +So, we need to figure out what m1 & m2 might have been, +given the other values. + +Check m3: + + m3 = m2 when m1 = 0 + m3 = 1 when m1 = 1 + + [deriv of m3 with respect to m1 = 1 - m2, which is positive] + + so check that m3 is between m2 and 1 + +Then check m3*b3: + + b3*m3 = m2*b2 when m1 = 0 or b1 = 0 + b3*m3 = (1 - m2) + m2*b2 when m1 = b1 = 1 + + [deriv with respect to m1 is b1*(1-m2), which is positive] + [deriv with respect to b1 is m1*(1-m2), which is positive] + + So check that m3*b3 is between m2*b2 and (1 - m2) + m2*b2 + +This is all in alphas from 0 to 1 and needs to be from 255 to 0. +Converting (but using the same names) for the alpha test, we get: + +(<= (- 1 (/ m2 255)) + (- 1 (/ m3 255)) + 1) + +sub1 to each: + +(<= (- (/ m2 255)) + (- (/ m3 255)) + 0) + +mult by 255: + +(<= (- m2) + (- m3) + 0) + +negate and flip ineq: + + +(>= m2 m3 0) + +flip ineq back: + +(<= 0 m3 m2) + + +Here's the original scheme expression for the second check: + +(<= (* m2 b2) + (* m3 b3) + (+ (- 1 m2) (* m2 b2)) + +converting from the computer's coordinates, we get: + + +(<= (* (- 1 (/ m2 255)) (- 1 (/ b2 255))) + (* (- 1 (/ m3 255)) (- 1 (/ b3 255))) + (+ (- 1 (- 1 (/ m2 255))) + (* (- 1 (/ m2 255)) (- 1 (/ b2 255))))) + +;; multiplying out the binomials: + +(<= (+ 1 + (- (/ m2 255)) + (- (/ b2 255)) + (/ (* m2 b2) (* 255 255))) + (+ 1 + (- (/ m3 255)) + (- (/ b3 255)) + (/ (* m3 b3) (* 255 255))) + (+ (- 1 (- 1 (/ m2 255))) + (+ 1 + (- (/ m2 255)) + (- (/ b2 255)) + (/ (* m2 b2) (* 255 255))))) + +;; simplifying the last term + +(<= (+ 1 + (- (/ m2 255)) + (- (/ b2 255)) + (/ (* m2 b2) (* 255 255))) + (+ 1 + (- (/ m3 255)) + (- (/ b3 255)) + (/ (* m3 b3) (* 255 255))) + (+ 1 + (- (/ b2 255)) + (/ (* m2 b2) (* 255 255)))) + +;; multiply thru by 255: + +(<= (+ 255 + (- m2) + (- b2) + (* m2 b2 1/255)) + (+ 255 + (- m3) + (- b3) + (* m3 b3 1/255)) + (+ 255 + (- b2) + (* m2 b2 1/255))) + +;; subtract out 255 from each: + +(<= (+ (- m2) + (- b2) + (* m2 b2 1/255)) + (+ (- m3) + (- b3) + (* m3 b3 1/255)) + (+ (- b2) + (* m2 b2 1/255))) + +;; negate them all, and reverse the inequality + +(>= (+ m2 b2 (* m2 b2 -1/255)) + (+ m3 b3 (* m3 b3 -1/255)) + (+ b2 (* m2 b2 -1/255))) + +;; aka + +(<= (+ b2 (* m2 b2 -1/255)) + (+ m3 b3 (* m3 b3 -1/255)) + (+ m2 b2 (* m2 b2 -1/255))) + +|# + +;; in the above, m3 & b3 come from iv +;; and m2 & b2 come from av +(define (first-in-second? iv av xd) + (let loop ([i (vector-length av)]) + (or (zero? i) + (let ([a (- i 4)] + [r (- i 3)] + [g (- i 2)] + [b (- i 1)]) + (let* ([m2 (vector-ref av a)] + [m3 (vector-ref iv (+ xd a))] + [test + (lambda (b2 b3) + (<= (+ b2 (* m2 b2 -1/255)) + (+ m3 b3 (* m3 b3 -1/255)) + (+ m2 b2 (* m2 b2 -1/255))))]) + (and (<= 0 m3 m2) + (test (vector-ref av r) (vector-ref iv (+ xd r))) + (test (vector-ref av g) (vector-ref iv (+ xd g))) + (test (vector-ref av b) (vector-ref iv (+ xd b))) + (loop (- i 4)))))))) + +;; ---------------------------------------- + +(define (image->color-list i-raw) + (check-image 'image->color-list i-raw "first") + (let* ([cis (coerce-to-cache-image-snip i-raw)] + [i (send cis get-bitmap)]) + (cond + [(not i) '()] + [else + (let* ([iw (send i get-width)] + [ih (send i get-height)] + [new-bitmap (make-object bitmap% iw ih)] + [bdc (make-object bitmap-dc% new-bitmap)]) + (send bdc clear) + (send bdc draw-bitmap i 0 0 'solid + (send the-color-database find-color "black") + (send i get-loaded-mask)) + (let ([is (make-bytes (* 4 iw ih))] + [cols (make-vector (* iw ih))]) + (send bdc get-argb-pixels 0 0 iw ih is) + (let yloop ([y 0][pos 0]) + (unless (= y ih) + (let xloop ([x 0][pos pos]) + (if (= x iw) + (yloop (add1 y) pos) + (begin + (vector-set! cols (+ x (* y iw)) + (make-color (bytes-ref is (+ 1 pos)) + (bytes-ref is (+ 2 pos)) + (bytes-ref is (+ 3 pos)))) + (xloop (add1 x) (+ pos 4))))))) + (send bdc set-bitmap #f) + (vector->list cols)))]))) + +(define (image->alpha-color-list i) + (check-image 'image->alpha-color-list i "first") + (let* ([argb (cond + [(is-a? i image-snip%) + (send (coerce-to-cache-image-snip i) get-argb)] + [(is-a? i cache-image-snip%) (send i get-argb)])] + [v (argb-vector argb)]) + (let loop ([i (vector-length v)] + [a null]) + (cond + [(zero? i) a] + [else (loop (- i 4) + (cons (make-alpha-color + (vector-ref v (- i 4)) + (vector-ref v (- i 3)) + (vector-ref v (- i 2)) + (vector-ref v (- i 1))) + a))])))) + +(define (color-list->image cl in-w in-h) + (check 'color-list->image color-list? cl "list-of-colors" "first") + (check-size/0 'color-list->image in-w "second") + (check-size/0 'color-list->image in-h "third") + (let ([w (inexact->exact in-w)] + [h (inexact->exact in-h)]) + (let ([px (floor (/ w 2))] [py (floor (/ h 2))]) + + (unless (= (* w h) (length cl)) + (error 'color-list->image + "given width times given height is ~a, but the given color list has ~a items" + (* w h) + (length cl))) + + (cond + [(or (equal? w 0) (equal? h 0)) + (rectangle w h 'solid 'black)] + [else + (unless (and (< 0 w 10000) (< 0 h 10000)) + (error 'color-list->image "cannot make ~a x ~a image" w h)) + + (let* ([bm (make-object bitmap% w h)] + [mask-bm (make-object bitmap% w h)] + [dc (make-object bitmap-dc% bm)] + [mask-dc (make-object bitmap-dc% mask-bm)]) + (unless (send bm ok?) + (error (format "cannot make ~a x ~a image" w h))) + (let ([is (make-bytes (* 4 w h) 0)] + [mask-is (make-bytes (* 4 w h) 0)] + [cols (list->vector (map (lambda (x) + (or (make-color% x) + (error 'color-list->image "color ~e is unknown" x))) + cl))]) + (let yloop ([y 0][pos 0]) + (unless (= y h) + (let xloop ([x 0][pos pos]) + (if (= x w) + (yloop (add1 y) pos) + (let* ([col (vector-ref cols (+ x (* y w)))] + [r (pk (send col red))] + [g (pk (send col green))] + [b (pk (send col blue))]) + (bytes-set! is (+ 1 pos) r) + (bytes-set! is (+ 2 pos) g) + (bytes-set! is (+ 3 pos) b) + (when (= 255 r g b) + (bytes-set! mask-is (+ 1 pos) 255) + (bytes-set! mask-is (+ 2 pos) 255) + (bytes-set! mask-is (+ 3 pos) 255)) + (xloop (add1 x) (+ pos 4))))))) + (send dc set-argb-pixels 0 0 w h is) + (send mask-dc set-argb-pixels 0 0 w h mask-is)) + (send dc set-bitmap #f) + (send mask-dc set-bitmap #f) + (bitmaps->cache-image-snip bm mask-bm px py))])))) + +(define (pk col) (min 255 (max 0 col))) + +(define (alpha-color-list->image cl in-w in-h) + (check 'alpha-color-list->image alpha-color-list? cl "list-of-alpha-colors" "first") + (check-size/0 'alpha-color-list->image in-w "second") + (check-size/0 'alpha-color-list->image in-h "third") + (let ([w (inexact->exact in-w)] + [h (inexact->exact in-h)]) + (let ([px (floor (/ w 2))] [py (floor (/ h 2))]) + (unless (= (* w h) (length cl)) + (error 'alpha-color-list->image + "given width times given height is ~a, but the given color list has ~a items" + (* w h) (length cl))) + (cond + [(or (equal? w 0) (equal? h 0)) + (rectangle w h 'solid 'black)] + [else + (unless (and (< 0 w 10000) (< 0 h 10000)) + (error 'alpha-color-list->image format "cannot make ~a x ~a image" w h)) + (let ([index-list (alpha-colors->ent-list cl)]) + (argb->cache-image-snip (make-argb (list->vector index-list) w h) px py))])))) + +;; alpha-colors->ent-list : (listof alpha-color) -> (listof number) +(define (alpha-colors->ent-list cl) + (let loop ([cl cl]) + (cond + [(null? cl) null] + [else + (let ([ac (car cl)]) + (list* (alpha-color-alpha ac) + (alpha-color-red ac) + (alpha-color-green ac) + (alpha-color-blue ac) + (loop (cdr cl))))]))) + +(define empty-image + (make-simple-cache-image-snip 0 0 void void)) + +(define-contract octet (combined natural (predicate (lambda (n) (<= n 255))))) +(define-contract rgb-color (predicate color?)) +(define-contract mode (one-of "solid" "outline")) +(define-contract image (predicate image?)) +(define-contract image-color (predicate image-color?)) +(define-contract h-place (mixed integer (one-of "left" "right" "center"))) +(define-contract v-place (mixed integer (one-of "top" "bottom" "center"))) +(define-contract h-mode (one-of "left" "right" "center")) +(define-contract v-mode (one-of "top" "bottom" "center")) diff --git a/collects/deinprogramm/info-i.ss b/collects/deinprogramm/info-i.ss new file mode 100644 index 0000000000..044c8a4c8c --- /dev/null +++ b/collects/deinprogramm/info-i.ss @@ -0,0 +1,218 @@ +(module info-i mzscheme + + (provide (all-from-except mzscheme + define let let* letrec lambda cond if begin + display newline read #%app) + symbol=? + info-i-version + (all-from "define-record-procedures.ss")) + + + (define-syntax provide/rename + (syntax-rules () + ((provide/rename (here there) ...) + (begin + (provide (rename here there)) ...)))) + + (provide/rename + (info-i-define define) + (info-i-let let) + (info-i-let* let*) + (info-i-letrec letrec) + (info-i-lambda lambda) + (info-i-cond cond) + (info-i-if if) + (info-i-begin begin) + (info-i-display display) + (info-i-newline newline) + (info-i-read read) + (info-i-app #%app)) + + (require "define-record-procedures.ss") + + (require-for-syntax "syntax-checkers.ss") + + (define-syntax (info-i-define stx) + (syntax-case stx () + ((info-i-define) + (raise-syntax-error + #f "Define erwartet zwei Operanden, nicht null" stx)) + ((info-i-define v) + (raise-syntax-error + #f "Define erwartet zwei Operanden, nicht einen" stx)) + ((info-i-define (f arg ...) body) + (begin + (check-for-id! (syntax f) + "Funktionsname im define ist kein Bezeichner") + (check-for-id-list! + (syntax->list (syntax (arg ...))) + "Argument im define ist kein Bezeichner") + (syntax/loc stx (define (f arg ...) body)))) + ((info-i-define (f arg ... . rest) body) + (begin + (check-for-id! + (syntax f) + "Funktionsname im define ist kein Bezeichner") + (check-for-id-list! + (syntax->list (syntax (arg ...))) + "Argument im define ist kein Bezeichner") + (check-for-id! + (syntax rest) + "Kein Bezeichern als Restlisten-Parameter von define") + (syntax/loc stx (define (f arg ... . rest) body)))) + ((info-i-define (f arg ...) body1 body2 ...) + (raise-syntax-error + #f "Mehr als ein Ausdruck im Rumpf von define" stx)) + ((info-i-define var expr) + (begin + (check-for-id! + (syntax var) + "Der erste Operand von define ist kein Bezeichner") + (syntax/loc stx (define var expr)))) + ((info-i-define v e1 e2 e3 ...) + (raise-syntax-error + #f "Define erwartet zwei Operanden, nicht" stx)))) + + (define-syntax (info-i-let stx) + (syntax-case stx () + ((info-i-let () body) + (syntax/loc stx body)) + ((info-i-let ((var expr) ...) body) + (begin + (check-for-id-list! + (syntax->list (syntax (var ...))) + "Kein Bezeichner in let-Bindung") + (syntax/loc stx ((lambda (var ...) body) expr ...)))) + ((info-i-let ((var expr) ...) body1 body2 ...) + (raise-syntax-error + #f "Let hat mehr als einen Ausdruck als Rumpf" stx)) + ((info-i-let expr ...) + (raise-syntax-error + #f "Let erwartet eine Liste von Bindungen (Paare aus Name und Ausdruck) und einen Rumpf" stx)))) + + (define-syntax (info-i-let* stx) + (syntax-case stx () + ((info-i-let* () body) + (syntax/loc stx body)) + ((info-i-let* ((var1 expr1) (var2 expr2) ...) body) + (begin + (check-for-id! + (syntax var1) + "Kein Bezeichner in let*-Bindung") + (syntax/loc stx ((lambda (var1) + (info-i-let* ((var2 expr2) ...) body)) + expr1)))) + ((info-i-let* ((var expr) ...) body1 body2 ...) + (raise-syntax-error + #f "Let* hat mehr als einen Ausdruck als Rumpf" stx)) + ((info-i-let* expr ...) + (raise-syntax-error + #f "Let* erwartet eine Liste von Bindungen (Paare aus Name und Ausdruck) und einen Rumpf" stx)))) + + (define-syntax (info-i-letrec stx) + (syntax-case stx () + ((info-i-letrec ((var expr) ...) body) + (begin + (check-for-id-list! + (syntax->list (syntax (var ...))) + "Kein Bezeichner in letrec-Bindung") + (syntax/loc stx (letrec ((var expr) ...) body)))) + ((info-i-letrec ((var expr) ...) body1 body2 ...) + (raise-syntax-error + #f "Letrec hat mehr als einen Ausdruck als Rumpf" stx)))) + + (define-syntax (info-i-lambda stx) + (syntax-case stx () + ((info-i-lambda (var ...) body) + (begin + (check-for-id-list! + (syntax->list (syntax (var ...))) + "Kein Bezeichner als Parameter von lambda") + (syntax/loc stx (lambda (var ...) body)))) + ((info-i-lambda (var ... . rest) body) + (begin + (check-for-id-list! + (syntax->list (syntax (var ...))) + "Kein Bezeichner als Parameter von lambda") + (check-for-id! + (syntax rest) + "Kein Bezeichner als Restlisten-Parameter von lambda") + (syntax/loc stx (lambda (var ... . rest) body)))) + ((info-i-lambda (var ...) body1 body2 ...) + (raise-syntax-error + #f "Lambda hat mehr als einen Ausdruck als Rumpf" stx)) + ((info-i-lambda var ...) + (raise-syntax-error + #f "Lambda erwartet eine Liste von Argumenten und einen Rumpf" stx)))) + + (define-syntax (info-i-cond stx) + (syntax-case stx (else) + ((info-i-cond (else e)) + (syntax/loc stx e)) + ((info-i-cond) + (syntax/loc stx (error "Kein Test im cond-Ausdruck war wahr"))) + ((info-i-cond (test rhs)) + (syntax/loc + stx + (if test + rhs + (info-i-cond)))) + ((info-i-cond (test rhs) clause1 clause2 ...) + (syntax/loc + stx + (if test + rhs + (info-i-cond clause1 clause2 ...)))) + ((info-i-cond (test rhs1 rhs2 ...) clause1 ...) + (raise-syntax-error + #f "Mehr als eine Antwort im Cond" stx)))) + + + (define-syntax (info-i-if stx) + (syntax-case stx () + ((info-i-if test cons) + (raise-syntax-error + #f "If braucht eine Alternative" stx)) + ((info-i-if test cons alt) + (syntax/loc stx (if test cons alt))) + ((info-i-if test cons alt1 alt2 ...) + (raise-syntax-error + #f "If mit mehr als drei Operanden" stx)) + ((info-i-if ...) + (raise-syntax-error + #f "If braucht drei Operanden" stx)))) + + (define-syntax (info-i-begin stx) + (syntax-case stx () + ((info-i-begin) + (raise-syntax-error + #f "Begin braucht mindestens einen Operanden" stx)) + ((info-i-begin expr1 expr2 ...) + (syntax/loc stx (begin expr1 expr2 ...))))) + + (define-syntax (info-i-app stx) + (syntax-case stx () + ((_) + (raise-syntax-error + #f "Zusammengesetzte Form ohne Operator" (syntax/loc stx ()))) + ((_ datum1 . datum2) + (syntax/loc stx (#%app datum1 . datum2))))) + + (define (info-i-display e) + (display e)) + + (define (info-i-newline) + (newline)) + + (define (info-i-read) + (read)) + + (define (symbol=? s1 s2) + (if (not (symbol? s1)) + (error "Erstes Argument von symbol=? ist kein Symbol")) + (if (not (symbol? s2)) + (error "Zweites Argument von symbol=? ist kein Symbol")) + (equal? s1 s2)) + + (define info-i-version "27.1.2005") +) diff --git a/collects/deinprogramm/info.ss b/collects/deinprogramm/info.ss new file mode 100644 index 0000000000..9580ccc948 --- /dev/null +++ b/collects/deinprogramm/info.ss @@ -0,0 +1,15 @@ +(module info (lib "infotab.ss" "setup") + (define name "DeinProgramm") + + (define tools '("deinprogramm-langs.ss")) + + (define tool-icons '(("logo-small.png" "deinprogramm"))) + (define tool-names '("DeinProgramm")) + (define tool-urls '("http://www.deinprogramm.de/dmda/")) + + (define compile-omit-files + '("define-record-procedures.scm" + "convert-explicit.scm" + "line3d.scm"))) + + diff --git a/collects/deinprogramm/line3d.scm b/collects/deinprogramm/line3d.scm new file mode 100644 index 0000000000..5fc3d7c723 --- /dev/null +++ b/collects/deinprogramm/line3d.scm @@ -0,0 +1,510 @@ +;; ############################################### +;; ############################################### +;; +;; Mini-3D-Engine +;; +;; 3D-Object are represented with line primitives +;; +;; Martin Bokeloh, Sebastian Veith +;; ############################################### +;; ############################################### + + +;; ----------------------------------- +;; some linear algebra tools +;; ----------------------------------- + +;; 3D-vector +(define-record-procedures vec3 + make-vec3 vec3? + (vec3-x + vec3-y + vec3-z)) + +;; return a+b +;; add-vec3 : vec3 vec3 -> vec3 +(define add-vec3 + (lambda (a b) + (make-vec3 + (+ (vec3-x a) (vec3-x b)) + (+ (vec3-y a) (vec3-y b)) + (+ (vec3-z a) (vec3-z b))))) + +;; return a-b +;; sub-vec3 : vec3 vec3 -> vec3 +(define sub-vec3 + (lambda (a b) + (make-vec3 + (- (vec3-x a) (vec3-x b)) + (- (vec3-y a) (vec3-y b)) + (- (vec3-z a) (vec3-z b))))) + +;; return v*s +;; mult-vec3 : vec3 number -> vec3 +(define mult-vec3 + (lambda (v s) + (make-vec3 + (* (vec3-x v) s) + (* (vec3-y v) s) + (* (vec3-z v) s)))) + +;; return v/s +;; div-vec3 : vec3 number -> vec3 +(define div-vec3 + (lambda (v s) + (mult-vec3 v (/ 1 s)))) + +;; return a*b +;; dotproduct-vec3 : vec3 vec3 -> Number +(define dotproduct-vec3 + (lambda (a b) + (+ + (* (vec3-x a) (vec3-x b)) + (* (vec3-y a) (vec3-y b)) + (* (vec3-z a) (vec3-z b))))) + +;; compute quadratic euclidian norm +;; normquad-vec3 : vec3 -> Number +(define normquad-vec3 + (lambda (a) + (+ + (* (vec3-x a) (vec3-x a)) + (* (vec3-y a) (vec3-y a)) + (* (vec3-z a) (vec3-z a))))) + +;; compute euclidian norm +;; norm-vec3 : vec3 -> Number +(define norm-vec3 + (lambda (a) + (sqrt (normquad-vec3 a)))) + +;; normalize vector +;; normalize-vec3 : vec3 -> vec3 +(define normalize-vec3 + (lambda (a) + (div-vec3 a (norm-vec3 a)))) + +;; cross product (computes a vector perpendicular to both input vectors) +;; crossproduct-vec3 : vec3 vec3 -> vec3 +(define crossproduct-vec3 + (lambda (a b) + (make-vec3 + (- (* (vec3-y a) (vec3-z b)) (* (vec3-z a) (vec3-y b))) + (- (* (vec3-z a) (vec3-x b)) (* (vec3-x a) (vec3-z b))) + (- (* (vec3-x a) (vec3-y b)) (* (vec3-y a) (vec3-x b)))))) + +;; 4D-vector +(define-record-procedures vec4 + make-vec4 vec4? + (vec4-x + vec4-y + vec4-z + vec4-w)) + +;; expands a 3d-vector to a 4d-vector (v,s) +;; expand-vec3 : vec3 number -> vec4 +(define expand-vec3 + (lambda (v s) + (make-vec4 (vec3-x v) (vec3-y v) (vec3-z v) s))) + +;; return a+b +;; add-vec4 : vec4 vec4 -> vec4 +(define add-vec4 + (lambda (a b) + (make-vec4 + (+ (vec4-x a) (vec4-x b)) + (+ (vec4-y a) (vec4-y b)) + (+ (vec4-z a) (vec4-z b)) + (+ (vec4-w a) (vec4-w b))))) + +;; return a-b +;; sub-vec4 : vec4 vec4 -> vec4 +(define sub-vec4 + (lambda (a b) + (make-vec4 + (- (vec4-x a) (vec4-x b)) + (- (vec4-y a) (vec4-y b)) + (- (vec4-z a) (vec4-z b)) + (- (vec4-w a) (vec4-w b))))) + +;; return v*s +;; mult-vec4 : vec4 number -> vec4 +(define mult-vec4 + (lambda (v s) + (make-vec4 + (* (vec4-x v) s) + (* (vec4-y v) s) + (* (vec4-z v) s) + (* (vec4-w v) s)))) + +;; return v/s +;; div-vec4 : vec4 number -> vec4 +(define div-vec4 + (lambda (v s) + (mult-vec4 v (/ 1 s)))) + +;; return a*b +;; dotproduct-vec4 : vec4 vec4 -> Number +(define dotproduct-vec4 + (lambda (a b) + (+ + (* (vec4-x a) (vec4-x b)) + (* (vec4-y a) (vec4-y b)) + (* (vec4-z a) (vec4-z b)) + (* (vec4-w a) (vec4-w b))))) + +;; compute quadratic euclidian norm +;; normquad-vec4 : vec4 -> Number +(define normquad-vec4 + (lambda (a) + (+ + (* (vec4-x a) (vec4-x a)) + (* (vec4-y a) (vec4-y a)) + (* (vec4-z a) (vec4-z a)) + (* (vec4-w a) (vec4-w a))))) + +;; compute euclidian norm +;; norm-vec4 : vec4 -> Number +(define norm-vec4 + (lambda (a) + (sqrt (normquad-vec4 a)))) + +;; normalize vector +;; normalize-vec4 : vec4 -> vec4 +(define normalize-vec4 + (lambda (a) + (/ a (norm-vec4 a)))) + +;; 4x4 matrix (implemented with 4 row vectors; vec4) +(define-record-procedures matrix4x4 + make-matrix4x4 matrix4x4? + (matrix4x4-1 + matrix4x4-2 + matrix4x4-3 + matrix4x4-4)) + +;; create 4x4 from 4 3d-vectors +;; create-matrix4x4 : vec3 vec3 vec3 vec3 -> matrix4x4 +(define create-matrix4x4 + (lambda (v1 v2 v3 v4) + (make-matrix4x4 + (expand-vec3 v1 0 ) + (expand-vec3 v2 0 ) + (expand-vec3 v3 0 ) + (expand-vec3 v4 1 )))) + +;; return a^T +;; transpose-matrix4x4 : matrix4x4 -> matrix4x4 +(define transpose-matrix4x4 + (lambda (a) + (make-matrix4x4 + (make-vec4 (vec4-x (matrix4x4-1 a)) + (vec4-x (matrix4x4-2 a)) + (vec4-x (matrix4x4-3 a)) + (vec4-x (matrix4x4-4 a))) + (make-vec4 (vec4-y (matrix4x4-1 a)) + (vec4-y (matrix4x4-2 a)) + (vec4-y (matrix4x4-3 a)) + (vec4-y (matrix4x4-4 a))) + (make-vec4 (vec4-z (matrix4x4-1 a)) + (vec4-z (matrix4x4-2 a)) + (vec4-z (matrix4x4-3 a)) + (vec4-z (matrix4x4-4 a))) + (make-vec4 (vec4-w (matrix4x4-1 a)) + (vec4-w (matrix4x4-2 a)) + (vec4-w (matrix4x4-3 a)) + (vec4-w (matrix4x4-4 a)))))) + +;; multiply 4x4 matrix with vec4 +;; multiply-matrix-vec4 : matrix4x4 vec4 -> vec4 +(define multiply-matrix-vec4 + (lambda (m v) + (make-vec4 (dotproduct-vec4 (matrix4x4-1 m) v) + (dotproduct-vec4 (matrix4x4-2 m) v) + (dotproduct-vec4 (matrix4x4-3 m) v) + (dotproduct-vec4 (matrix4x4-4 m) v)))) + +;; multiply homogenous matrix with (vec3,1) and project onto plane w=1 +;; transform-vec3 : matrix4x4 vec3 -> vec3 +(define transform-vec3 + (lambda (m v) + (let ((v4 (make-vec4 (vec3-x v) (vec3-y v) (vec3-z v) 1))) + (div-vec3 (make-vec3 (dotproduct-vec4 (matrix4x4-1 m) v4) + (dotproduct-vec4 (matrix4x4-2 m) v4) + (dotproduct-vec4 (matrix4x4-3 m) v4)) + (dotproduct-vec4 (matrix4x4-4 m) v4))))) + + +;; return a*b +;; multiply-matrix : matrix4x4 matrix4x4 -> matrix4x4 +(define multiply-matrix + (lambda (a b) + (let ( (b^T (transpose-matrix4x4 b)) ) + (make-matrix4x4 + (make-vec4 (dotproduct-vec4 (matrix4x4-1 a) (matrix4x4-1 b^T)) + (dotproduct-vec4 (matrix4x4-1 a) (matrix4x4-2 b^T)) + (dotproduct-vec4 (matrix4x4-1 a) (matrix4x4-3 b^T)) + (dotproduct-vec4 (matrix4x4-1 a) (matrix4x4-4 b^T))) + (make-vec4 (dotproduct-vec4 (matrix4x4-2 a) (matrix4x4-1 b^T)) + (dotproduct-vec4 (matrix4x4-2 a) (matrix4x4-2 b^T)) + (dotproduct-vec4 (matrix4x4-2 a) (matrix4x4-3 b^T)) + (dotproduct-vec4 (matrix4x4-2 a) (matrix4x4-4 b^T))) + (make-vec4 (dotproduct-vec4 (matrix4x4-3 a) (matrix4x4-1 b^T)) + (dotproduct-vec4 (matrix4x4-3 a) (matrix4x4-2 b^T)) + (dotproduct-vec4 (matrix4x4-3 a) (matrix4x4-3 b^T)) + (dotproduct-vec4 (matrix4x4-3 a) (matrix4x4-4 b^T))) + (make-vec4 (dotproduct-vec4 (matrix4x4-4 a) (matrix4x4-1 b^T)) + (dotproduct-vec4 (matrix4x4-4 a) (matrix4x4-2 b^T)) + (dotproduct-vec4 (matrix4x4-4 a) (matrix4x4-3 b^T)) + (dotproduct-vec4 (matrix4x4-4 a) (matrix4x4-4 b^T))))))) + +;; create a matrix which translates (moves) by a 3d-vector +;; create-translation-matrix: vec3 -> matrix4x4 +(define create-translation-matrix + (lambda (translation) + (make-matrix4x4 + (make-vec4 1 0 0 (vec3-x translation)) + (make-vec4 0 1 0 (vec3-y translation)) + (make-vec4 0 0 1 (vec3-z translation)) + (make-vec4 0 0 0 1)))) + +;; create a matrix which rotates around the x-axis +;; create-rotation-x-matrix: Number -> matrix4x4 +(define create-rotation-x-matrix + (lambda (angle) + (make-matrix4x4 + (make-vec4 1 0 0 0) + (make-vec4 0 (cos angle) (sin angle) 0) + (make-vec4 0 (-(sin angle)) (cos angle) 0) + (make-vec4 0 0 0 1)))) + +;; create a matrix which rotates around the y-axis +;; create-rotation-y-matrix: Number -> matrix4x4 +(define create-rotation-y-matrix + (lambda (angle) + (make-matrix4x4 + (make-vec4 (cos angle) 0 (sin angle) 0) + (make-vec4 0 1 0 0) + (make-vec4 (-(sin angle)) 0 (cos angle) 0) + (make-vec4 0 0 0 1)))) + +;; create a matrix which rotates around the z-axis +;; create-rotation-z-matrix: Number -> matrix4x4 +(define create-rotation-z-matrix + (lambda (angle) + (make-matrix4x4 + (make-vec4 (cos angle) (sin angle) 0 0) + (make-vec4 (-(sin angle)) (cos angle) 0 0) + (make-vec4 0 0 1 0) + (make-vec4 0 0 0 1)))) + +(define PI 3.14159265) +(define PI/2 (/ PI 2)) +(define PI/4 (/ PI 4)) + +; output a vector +; print-vec4 : vec4 -> string +(define print-vec4 + (lambda (v) + (string-append (number->string (vec4-x v)) "\t" + (number->string (vec4-y v)) "\t" + (number->string (vec4-z v)) "\t" + (number->string (vec4-w v))))) + +; output a matrix +; print-matrix4x4 : matrix4x4 -> string +(define print-matrix4x4 + (lambda (m) + (let ((m^T (transpose-matrix4x4 m))) + (string-append (print-vec4 (matrix4x4-1 m^T)) "\n" + (print-vec4 (matrix4x4-2 m^T)) "\n" + (print-vec4 (matrix4x4-3 m^T)) "\n" + (print-vec4 (matrix4x4-4 m^T)) "\n")))) + +;; --------------------------------------------- +;; camera and projection +;; --------------------------------------------- + +; create a look-at modelview matrix +; M = (v1 v2 v3 v4) +; (0 0 0 1 ) +; v1 = (lookat - position) x upvector +; v2 = ((lookat - position) x upvector) x (lookat - position) +; v3 = (lookat - position) +; v4 = (0 0 0) +; create-lookat-matrix : vec3 vec3 vec3 -> matrix4x4 +(define create-lookat-matrix + (lambda (position lookat upvector) + (let* ((viewdirection (normalize-vec3 (sub-vec3 position lookat))) + (normed-upvector (normalize-vec3 upvector)) + (rightvector (crossproduct-vec3 viewdirection normed-upvector))) + (multiply-matrix + (create-matrix4x4 + (normalize-vec3 rightvector) + (normalize-vec3 (crossproduct-vec3 rightvector viewdirection)) + viewdirection + (make-vec3 0 0 0)) + (create-translation-matrix (mult-vec3 position -1)))))) + +; projection with a specified vertical viewing angle +; create-projection-matrix : number -> matrix4x4 +(define create-projection-matrix + (lambda (vertical-fov/2) + (let ((f (/ (cos vertical-fov/2) (sin vertical-fov/2)))) + (make-matrix4x4 + (make-vec4 f 0 0 0) + (make-vec4 0 f 0 0) + (make-vec4 0 0 0 0) + (make-vec4 0 0 1 0))))) + +; transforms camera-space into image-space +; create-viewport-matrix : number number -> number +(define create-viewport-matrix + (lambda (screenwidth screenheight) + (let ((screenwidth/2 (/ screenwidth 2)) + (screenheight/2 (/ screenheight 2))) + (make-matrix4x4 + (make-vec4 screenwidth/2 0 0 screenwidth/2) + (make-vec4 0 screenwidth/2 0 screenheight/2) + (make-vec4 0 0 0 0) + (make-vec4 0 0 0 1))))) + +; create a complete camera matrix +; create-camera-matrix : +(define create-camera-matrix + (lambda (position lookat vertical-fov screenwidth screenheight) + (multiply-matrix + (multiply-matrix + (create-viewport-matrix screenwidth screenheight) + (create-projection-matrix (* (/ vertical-fov 360) PI))) + (create-lookat-matrix position lookat (make-vec3 0 1 0))))) + +;; ---------------------------------------------- +;; scene +;; ---------------------------------------------- + +; defines a colored line between two points (3D) +(define-record-procedures line3d + make-line3d line3d? + (line3d-a line3d-b line3d-color)) + +; creates a box centered at (0,0,0) with the given dimensions. +; create-box : number number number color -> list(line3d) +(define create-box + (lambda (width height depth color) + (let ((corner1 (make-vec3 (- width) (- height) (- depth))) + (corner2 (make-vec3 width (- height) (- depth))) + (corner3 (make-vec3 width height (- depth))) + (corner4 (make-vec3 (- width) height (- depth))) + (corner5 (make-vec3 (- width) (- height) depth)) + (corner6 (make-vec3 width (- height) depth)) + (corner7 (make-vec3 width height depth)) + (corner8 (make-vec3 (- width) height depth))) + (list + (make-line3d corner1 corner2 color) + (make-line3d corner2 corner3 color) + (make-line3d corner3 corner4 color) + (make-line3d corner4 corner1 color) + (make-line3d corner5 corner6 color) + (make-line3d corner6 corner7 color) + (make-line3d corner7 corner8 color) + (make-line3d corner8 corner5 color) + (make-line3d corner1 corner5 color) + (make-line3d corner1 corner5 color) + (make-line3d corner2 corner6 color) + (make-line3d corner3 corner7 color) + (make-line3d corner4 corner8 color))))) + +; apply transformation to every given line +; transform-primitive-list: list(line3d) matrix4x4 -> list(line3d) +(define transform-primitive-list + (lambda (l mat) + (cond + ((pair? l) (transform-primitive-list-helper l mat empty)) + ((empty? l) empty)))) + +; transform-primitive-list-helper : list(line3d) matrix4x4 list(line3d) -> list(line3d) +(define transform-primitive-list-helper + (lambda (l mat result) + (cond + ((pair? l) + (transform-primitive-list-helper (rest l) mat + (make-pair (make-line3d (transform-vec3 mat (line3d-a (first l))) + (transform-vec3 mat (line3d-b (first l))) + (line3d-color (first l))) result))) + ((empty? l) result)))) + +;; --------------------------------------------- +;; rendering +;; --------------------------------------------- + +; w-clip epsilon +(define clip-epsilon -0.1) + +;; clip line on plane w=clip-epsilon +;; clipline: vec4 vec4 color -> image +(define clipline + (lambda (screenWidth screenHeight inside outside color) + (let* ((delta-vec (sub-vec4 outside inside)) + (f (/ (- clip-epsilon (vec4-w inside)) (- (vec4-w outside) (vec4-w inside)))) + ; compute intersection with clipping plane + (clipped-point (add-vec4 inside (mult-vec4 delta-vec f))) + ; project points by normalising to w=1 + (inside-projected (div-vec4 inside (vec4-w inside))) + (clipped-point-projected (div-vec4 clipped-point (vec4-w clipped-point)))) + (line screenWidth screenHeight (vec4-x inside-projected) (vec4-y inside-projected) + (vec4-x clipped-point-projected) (vec4-y clipped-point-projected) color)))) + + +; render line with clipping +; render-clipped-line3d : N N vec4 vec4 matrix4x4 -> image +(define render-clipped-line3d + (lambda (screenWidth screenHeight l camera-matrix) + (let* ((point-a (line3d-a l)) + (point-b (line3d-b l)) + (point-a-transformed (multiply-matrix-vec4 camera-matrix + (make-vec4 (vec3-x point-a) (vec3-y point-a) (vec3-z point-a) 1))) + (point-b-transformed (multiply-matrix-vec4 camera-matrix + (make-vec4 (vec3-x point-b) (vec3-y point-b) (vec3-z point-b) 1))) + (projected-point1 (transform-vec3 camera-matrix (line3d-a l))) + (projected-point2 (transform-vec3 camera-matrix (line3d-b l)))) + (cond + ((and (< (vec4-w point-a-transformed) clip-epsilon) + (< (vec4-w point-b-transformed) clip-epsilon)) + (line screenWidth screenHeight (vec3-x projected-point1) (vec3-y projected-point1) + (vec3-x projected-point2) (vec3-y projected-point2) (line3d-color l))) + ((and (>= (vec4-w point-a-transformed) clip-epsilon) + (< (vec4-w point-b-transformed) clip-epsilon)) + (clipline screenWidth screenHeight point-b-transformed point-a-transformed (line3d-color l))) + ((and (>= (vec4-w point-b-transformed) clip-epsilon) + (< (vec4-w point-a-transformed) clip-epsilon)) + (clipline screenWidth screenHeight point-a-transformed point-b-transformed (line3d-color l))) + (else (line screenWidth screenHeight -1 0 0 0 (line3d-color l))))))) + +; render line without clipping (not used anymore) +; render-line3d : N N line3d matrix4x4 -> image +(define render-line3d + (lambda (screenWidth screenHeight l camera-matrix) + (let ((projected-point1 (transform-vec3 camera-matrix (line3d-a l))) + (projected-point2 (transform-vec3 camera-matrix (line3d-b l)))) + (line screenWidth screenHeight (vec3-x projected-point1) (vec3-y projected-point1) + (vec3-x projected-point2) (vec3-y projected-point2) (line3d-color l))))) + +; render scene into an image +; render-scene: N N list(line3d) matrix4x4 -> image +(define render-scene + (lambda (screenWidth screenHeight scene camera-matrix) + (cond + ((empty? scene)(line screenWidth screenHeight 0 0 0 0 "white")) + ((pair? scene) + (render-scene-helper screenWidth screenHeight (rest scene) camera-matrix + (render-clipped-line3d screenWidth screenHeight (first scene) camera-matrix)))))) + +; render-scene-helper: list(line3d) matrix4x4 image -> image +(define render-scene-helper + (lambda (screenWidth screenHeight scene camera-matrix screen) + (cond + ((empty? scene) screen) + ((pair? scene) (render-scene-helper screenWidth screenHeight (rest scene) camera-matrix + (overlay screen + (render-clipped-line3d screenWidth screenHeight (first scene) camera-matrix) 0 0)))))) \ No newline at end of file diff --git a/collects/deinprogramm/line3d.ss b/collects/deinprogramm/line3d.ss new file mode 100644 index 0000000000..45dfe92025 --- /dev/null +++ b/collects/deinprogramm/line3d.ss @@ -0,0 +1,60 @@ +(module line3d mzscheme + (require "world.ss" + "define-record-procedures.ss") + (require (only "DMdA-vanilla.ss" + empty make-pair empty? + first rest)) + (provide make-vec3 + vec3-x + vec3-y + vec3-z + add-vec3 + sub-vec3 + mult-vec3 + div-vec3 + dotproduct-vec3 + normquad-vec3 + norm-vec3 + normalize-vec3 + crossproduct-vec3 + make-vec4 + vec4-x + vec4-y + vec4-z + vec4-w + add-vec4 + sub-vec4 + mult-vec4 + div-vec4 + dotproduct-vec4 + normquad-vec4 + norm-vec4 + normalize-vec4 + expand-vec3 + make-matrix4x4 + create-matrix4x4 + transpose-matrix4x4 + multiply-matrix-vec4 + transform-vec3 + multiply-matrix + create-translation-matrix + create-rotation-x-matrix + create-rotation-y-matrix + create-rotation-z-matrix + print-vec4 + print-matrix4x4 + create-lookat-matrix + create-projection-matrix + create-viewport-matrix + create-camera-matrix + make-line3d + line3d-a + line3d-b + line3d-color + create-box + transform-primitive-list + render-scene + ) + + (require (lib "include.ss")) + (include "line3d.scm")) \ No newline at end of file diff --git a/collects/deinprogramm/logo-small.png b/collects/deinprogramm/logo-small.png new file mode 100644 index 0000000000..d5ed30162a Binary files /dev/null and b/collects/deinprogramm/logo-small.png differ diff --git a/collects/deinprogramm/run-dmda-code.ss b/collects/deinprogramm/run-dmda-code.ss new file mode 100644 index 0000000000..1a6604d181 --- /dev/null +++ b/collects/deinprogramm/run-dmda-code.ss @@ -0,0 +1,57 @@ +(module run-dmda-code mzscheme + (require (lib "mred.ss" "mred") + (lib "class.ss") + (lib "match.ss") + (lib "modread.ss" "syntax")) + + (define (run-dmda-file filename) + (let ((p (open-input-graphical-file/fixed filename)) + (expected-module-name + (let-values (((base name dir) (split-path filename))) + (string->symbol (path->string (path-replace-suffix name #"")))))) + (dynamic-wind + values + (lambda () + (with-module-reading-parameterization + (lambda () + (let* ((code (read-syntax filename p)) + (pimped-code + (syntax-case code () + ((?module ?name ?language ?body ...) + (syntax + (?module ?name ?language + (require (lib "testing.ss" "htdp")) + ?body ...))))) + (module-ized-code + (check-module-form pimped-code expected-module-name filename))) + (eval module-ized-code) + (dynamic-require expected-module-name #f))))) + (lambda () + (close-input-port p))))) + +;; The following definitions work around a bug in PLT 371. + +;; build-input-port : string -> (values input any) +;; constructs an input port for the load handler. Also +;; returns a value representing the source of code read from the file. + (define (build-input-port filename) + (let ([p (open-input-file filename)]) + (port-count-lines! p) + (let ([p (cond + [(regexp-match-peek #rx#"^(?:#reader[(]lib\"read[.]ss\"\"wxme\"[)])?WXME01[0-9][0-9] ##[ \r\n]" p) + (let ([t (make-object text%)]) + (send t insert-port p 'standard) + (close-input-port p) + (open-input-text-editor t 0 'end values filename))] + [else p])]) + (port-count-lines! p) ; in case it's new + (values p filename)))) + + (define (open-input-graphical-file/fixed filename) + (let-values ([(p name) (build-input-port filename)]) + p)) + + (run-dmda-file + (vector-ref (current-command-line-arguments) 0)) + + ) diff --git a/collects/deinprogramm/scribblings/DMdA-advanced.scrbl b/collects/deinprogramm/scribblings/DMdA-advanced.scrbl new file mode 100644 index 0000000000..baa10bfdd6 --- /dev/null +++ b/collects/deinprogramm/scribblings/DMdA-advanced.scrbl @@ -0,0 +1,57 @@ +#lang scribble/doc +@(require scribblings/htdp-langs/common + "std-grammar.ss" + "prim-ops.ss" + (for-label deinprogramm/DMdA-assignments)) + +@title[#:style 'toc #:tag "DMdA-advanced"]{Die Macht der Abstraktion fortgeschritten} + +This is documentation for the language level @italic{Die Macht der +Abstraktion - fortgeschritten} that goes with the German textbook +@italic{Die Macht der Abstraktion}. + +@declare-exporting[deinprogramm/DMdA-advanced] + +@schemegrammar*-DMdA[ +#:literals (define-record-procedures-2 set!) +( + (define-record-procedures-2 id id id (field-spec ...)) + (define-record-procedures-parametric-2 (id id ...) id id (field-spec ...)) +) +( + [field-spec id (id id)] + [quoted id + number + string + character + (quoted ...) + #, @elem{@schemevalfont{'}@scheme[quoted]}] +) +( + (set! id expr) + (code:line #, @elem{@schemevalfont{'}@scheme[quoted]} (code:comment #, @seclink["advanced-quote"]{Quote-Literal})) +) +] + +@|prim-nonterms| + +@prim-ops['(lib "DMdA-advanced.ss" "deinprogramm") #'here] + +@section[#:tag "advanced-quote"]{Quote-Literal} + +@deftogether[( +@defform/none[(unsyntax @elem{@schemevalfont{'}@scheme[quoted]})] +@defform[(quote quoted)] +)]{ +Der Wert eines Quote-Literals hat die gleiche externe Repräsentation wie @scheme[quoted]. +} + +@section[#:tag "advanced-contracts"]{Verträge} + +@defidform[symbol]{ +Vertrag für Symbole. +} + +@section[#:tag "advanced-prim-op"]{Primitive Operationen} + +@prim-op-defns['(lib "DMdA-advanced.ss" "deinprogramm") #'here '()] diff --git a/collects/deinprogramm/scribblings/DMdA-assignments.scrbl b/collects/deinprogramm/scribblings/DMdA-assignments.scrbl new file mode 100644 index 0000000000..9c0a54a211 --- /dev/null +++ b/collects/deinprogramm/scribblings/DMdA-assignments.scrbl @@ -0,0 +1,59 @@ +#lang scribble/doc +@(require scribblings/htdp-langs/common + "std-grammar.ss" + "prim-ops.ss" + (for-label deinprogramm/DMdA-assignments)) + +@title[#:style 'toc #:tag "DMdA-assignments"]{Die Macht der Abstraktion mit Zuweisungen} + +This is documentation for the language level @italic{Die Macht der +Abstraktion mit Zuweisungen} to go with the German textbook +@italic{Die Macht der Abstraktion}. + +@declare-exporting[deinprogramm/DMdA-assignments] + +@schemegrammar*-DMdA[ +#:literals (define-record-procedures-2 define-record-procedures-parametric-2 set!) +( + (define-record-procedures-2 id id id (field-spec ...)) + (define-record-procedures-parametric-2 (id id ...) id id (field-spec ...)) +) +( + [field-spec id (id id)] +) +( + (set! id expr) +) +] + +@|prim-nonterms| + +@prim-ops['(lib "DMdA-assignments.ss" "deinprogramm") #'here] + +@section{@scheme[define-record-procedures-2]} + +@defform[(define-record-procedures-2 t c p (field-spec ...))]{ +Die @scheme[define-record-procedures-2]-Form ist eine Definition für +einen neuen Record-Typ. Dabei ist @scheme[t] der Name des Record-Vertrags, +@scheme[c] der Name des Konstruktors, @scheme[p] der Name des +Prädikats. Jedes @scheme[field-spec] kann entweder der Name eines Selektors +oder ein Paar @scheme[(id id)] aus dem Namen eines Selektors und dem Namen eines +Mutators sein. +} + +@section{@scheme[define-record-procedures-parametric-2]} + +@defform[(define-record-procedures-parametric-2 (t p1 ...) c p (field-spec1 ...))]{ +Diese Form ist wie @scheme[define-record-procedures-2], nur parametrisch +wie @schemeidfont{define-record-procedures-parametric}.} + +@section{@scheme[set!]} + +@defform[(set! id expr)]{ +Ein @scheme[set!]-Ausdruck ist eine Zuweisung, und ändert den Inhalt +der Zelle, die an @scheme[id] gebunden ist, auf den Wert von @scheme[expr]. +} + +@section[#:tag "assignments-prim-op"]{Primitive Operationen} + +@prim-op-defns['(lib "DMdA-assignments.ss" "deinprogramm") #'here '()] diff --git a/collects/deinprogramm/scribblings/DMdA-beginner.scrbl b/collects/deinprogramm/scribblings/DMdA-beginner.scrbl new file mode 100644 index 0000000000..1d73816596 --- /dev/null +++ b/collects/deinprogramm/scribblings/DMdA-beginner.scrbl @@ -0,0 +1,400 @@ +#lang scribble/doc +@(require scribblings/htdp-langs/common + scribble/struct + "std-grammar.ss" + "prim-ops.ss" + (for-label deinprogramm/DMdA-beginner)) + +@title[#:style 'toc #:tag "DMdA-beginner"]{Die Macht der Abstraktion - Anfänger} + +This is documentation for the language level @italic{Die Macht der +Abstraktion - Anfänger} to go with the German textbook @italic{Die +Macht der Abstraktion}. + +@declare-exporting[deinprogramm/DMdA-beginner] + +@schemegrammar*-DMdA[ +#:literals () +() () () +] + +@|prim-nonterms| + +@prim-ops['(lib "DMdA-beginner.ss" "deinprogramm") #'here] + +@; ---------------------------------------------------------------------- + +@section{Definitionen} + +@defform[(define id expr)]{ +Diese Form ist eine Definition, und bindet @scheme[id] als +globalen Namen an den Wert von @scheme[exp].} + +@section{Record-Typ-Definitionen} + +@defform[(define-record-procedures t c p (s1 ...))]{ + +Die @scheme[define-record-procedures]-Form ist eine Definition +für einen neuen Record-Typ. Dabei ist @scheme[t] der Name des Record-Vertrags, +@scheme[c] der Name des Konstruktors, @scheme[p] +der Name des Prädikats, und die @scheme[si] sind die +Namen der Selektoren.} + +@section[#:tag "application"]{Prozedurapplikation} + +@defform/none[(expr expr ...)]{ +Dies ist eine Prozeduranwendung oder Applikation. +Alle @scheme[expr]s werden ausgewertet: +Der Operator (also der erste Ausdruck) muß eine +Prozedur ergeben, die genauso viele Argumente +akzeptieren kann, wie es Operanden, also weitere @scheme[expr]s gibt. +Die Anwendung wird dann ausgewertet, indem der Rumpf +der Applikation ausgewertet wird, nachdem die Parameter +der Prozedur durch die Argumente, also die Werte der +Operanden ersetzt wurden.} + +@; @defform[(#%app id expr expr ...)]{ +@; +@; Eine Prozedurapplikation kann auch mit @scheme[#%app] geschrieben +@; werden, aber das macht eigentlich niemand.} + +@section{@scheme[#t] and @scheme[#f]} + +@as-index{@litchar{#t}} ist das Literal für den booleschen Wert "wahr", +@as-index{@litchar{#f}} das Literal für den booleschen Wert "falsch". + +@section{@scheme[lambda]} + +@defform[(lambda (id ...) expr)]{ +Ein Lambda-Ausdruck ergibt bei der Auswertung eine neue Prozedur.} + +@section[#:tag "id"]{Bezeichner} + +@defform/none[id]{ +Eine Variable bezieht sich auf die, von innen nach +außen suchend, nächstgelegene Bindung durch @scheme[lambda], @scheme[let], @scheme[letrec], oder +@scheme[let*]. Falls es keine solche lokale Bindung gibt, muß es eine +Definition oder eine eingebaute Bindung mit dem entsprechenden Namen +geben. Die Auswertung des Namens ergibt dann den entsprechenden +Wert. } + +@section{@scheme[cond]} + +@defform[(cond (expr expr) ... (expr expr))]{ +Ein @scheme[cond]-Ausdruck bildet eine Verzweigung, die aus mehreren +Zweigen besteht. Jeder Zweig besteht +aus einem Test und einem Ausdruck. Bei der Auswertung werden die +Zweige nacheinander abgearbeitet. Dabei wird jeweils zunächst der Test +ausgewertet, der jeweils einen booleschen Wert ergeben müssen. Beim +ersten Test, der @scheme[#t] ergibt, wird der Wert des Ausdrucks des Zweigs zum +Wert der gesamten Verzweigung. Wenn kein Test @scheme[#t] ergibt, wird das +Programm mit einer Fehlermeldung abgebrochen. +} + +@defform/none[#:literals (cond else) + (cond (expr expr) ... (else expr))]{ + Die Form des cond-Ausdrucks ist ähnlich zur vorigen, mit der + Ausnahme, daß in dem Fall, in dem kein Test @scheme[#t] ergibt, der Wert des + letzten Ausdruck zum Wert der @scheme[cond]-Form wird. +} + +@defidform[else]{ + +Das Schlüsselwort @scheme[else] kann nur in @scheme[cond] benutzt werden.} + +@; ---------------------------------------------------------------------- + +@section{@scheme[if]} + +@defform[(if expr expr expr)]{ +Eine @scheme[if]-Form ist eine binäre Verzweigung. Bei der Auswertung wird +zunächst der erste Operand ausgewertet (der Test), der einen +booleschen Wert ergeben muß. Ergibt er @scheme[#t], wird der Wert des zweiten +Operanden (die Konsequente) zum Wert der @scheme[if]-Form, bei @scheme[#f] der Wert des +dritten Operanden (die Alternative). +} + +@; ---------------------------------------------------------------------- + +@section{@scheme[and]} + +@defform[(and expr ...)]{ +Bei der Auswertung eines @scheme[and]-Ausdrucks werden nacheinander die +Operanden (die boolesche Werte ergeben müssen) ausgewertet. Ergibt +einer @scheme[#f], ergibt auch der and-Ausdruck @scheme[#f]; wenn alle +Operanden @scheme[#t] ergeben, ergibt auch der @scheme[and]-Ausdruck +@scheme[#t]. +} + +@; ---------------------------------------------------------------------- + +@section{@scheme[or]} + +@defform[(or expr ...)]{ +Bei der Auswertung eines @scheme[or]-Ausdrucks werden nacheinander die +Operanden (die boolesche Werte ergeben müssen) ausgewertet. Ergibt +einer @scheme[#t], ergibt auch der or-Ausdruck @scheme[#t]; wenn alle Operanden @scheme[#f] +ergeben, ergibt auch der @scheme[or]-Ausdruck @scheme[#f]. +} + +@section{@scheme[let], @scheme[letrec] und @scheme[let*]} + +@defform[(let ((id expr) ...) expr)]{ + +Bei einem @scheme[let]-Ausdruck werden zunächst die @scheme[expr]s aus +den @scheme[(id expr)]-Paaren ausgewertet. Ihre Werte werden dann im +Rumpf-@scheme[expr] für die Namen @scheme[id] eingesetzt. Dabei können +sich die Ausdrücke nicht auf die Namen beziehen. + +@schemeblock[ +(define a 3) +(let ((a 16) + (b a)) + (+ b a)) +=> 19] + +Das Vorkommen von @scheme[a] in der Bindung von @scheme[b] bezieht +sich also auf das @scheme[a] aus der Definition, nicht das @scheme[a] +aus dem @scheme[let]-Ausdruck. +} + +@defform[(letrec ((id expr) ...) expr)]{ +Ein @scheme[letrec]-Ausdruck ist +ähnlich zum entsprechenden @scheme[let]-Ausdruck, mit dem Unterschied, daß sich +die @scheme[expr]s aus den Bindungen auf die gebundenen Namen beziehen +dürfen.} + +@defform[(let* ((id expr) ...) expr)]{ +Ein @scheme[let*]-Ausdruck ist ähnlich zum entsprechenden +@scheme[let]-Ausdruck, mit dem Unterschied, daß sich die @scheme[expr]s +aus den Bindungen auf die Namen beziehen dürfen, die jeweils vor dem +@scheme[expr] gebunden wurden. Beispiel: + +@schemeblock[ +(define a 3) +(let* ((a 16) + (b a)) + (+ b a)) +=> 32] + +Das Vorkommen von @scheme[a] in der Bindung von @scheme[b] bezieht +sich also auf das @scheme[a] aus dem @scheme[let*]-Ausdruck, nicht das +@scheme[a] aus der globalen Definition. +} + +@section{@scheme[begin]} + +@defform[(begin expr expr ...)]{ +Bei der Auswertung eines @scheme[begin]-Ausdrucks werden nacheinander +die Operanden ausgewertet. Der Wert des letzten Ausdrucks wird der +Wert des @scheme[begin]-Ausdrucks. +} + +@section{Verträge} + +@subsection{@scheme[define-contract]} +@defform[(define-contract id contract)] +@defform/none[(define-contract (id p1 ...) contract)]{ +Die erste Form führt einen neuen Vertrag ein: +sie bindet den Namen @scheme[id] an den Vertrag @scheme[contract]. + +Die zweite Form führt einen @deftech{parametrischen Vertrag} (wie +@scheme[list]) ein, der über die Parameter @scheme[p1] +... abstrahiert. Der parametrische Vertrag kann dann als @schemeidfont['(id +a1 ...)] verwendet werden, wobei in @scheme[contract] für die +Parameter @scheme[p1] ... die @scheme[a1] ... eingesetzt werden. +} + +@subsection{Vertragserklärung} +@defform[(: id contract)]{ +Diese Form erklärt @scheme[contract] zum gültigen Vertrag für @scheme[id]. +} + +@defidform[number]{ +Vertrag für beliebige Zahlen. +} + +@defidform[real]{ +Vertrag für reelle Zahlen. +} + +@defidform[rational]{ +Vertrag für rationale Zahlen. +} + +@defidform[integer]{ +Vertrag für ganze Zahlen. +} + +@defidform[natural]{ +Vertrag für ganze, nichtnegative Zahlen. +} + +@defidform[boolean]{ +Vertrag für boolesche Werte. +} + +@defidform[true]{ +Vertrag für \scheme[#t]. +} + +@defidform[false]{ +Vertrag für \scheme[#f]. +} + +@defidform[string]{ +Vertrag für Zeichenketten. +} + +@defidform[empty-list]{ +Vertrag für die leere Liste. +} + +@subsection{@scheme[predicate]} +@defform[(predicate expr)]{ +Bei diesem Vertrag muß @scheme[expr] als Wert ein Prädikat haben, also +eine Prozedur, die einen beliebigen Wert akzeptiert und entweder @scheme[#t] +oder @scheme[#f] zurückgibt. +Der Vertrag ist dann für einen Wert gültig, wenn das Prädikat, darauf angewendet, +@scheme[#t] ergibt. +} + +@subsection{@scheme[one-of]} +@defform[(one-of expr ...)]{ +Dieser Vertrag ist für einen Wert gültig, wenn er gleich dem Wert eines +der @scheme[expr] ist. +} + +@subsection{@scheme[mixed]} +@defform[(mixed contract ...)]{ +Dieser Vertrag ist für einen Wert gültig, wenn er für einen der Verträge +@scheme[contract] gültig ist. +} + +@subsection[#:tag "proc-contract"]{Prozedur-Vertrag} +@defidform[->]{ +@defform/none[(contract ... -> contract)]{ +Dieser Vertrag ist dann für einen Wert gültig, wenn dieser eine +Prozedur ist. Er erklärt außerdem, daß die Verträge vor dem @scheme[->] +für die Argumente der Prozedur gelten und der Vertrag nach dem @scheme[->] +für den Rückgabewert. +}} +} + +@subsection{@scheme[property]} +@defform[(property expr contract)]{ +Dieser Vertrag ist für ein Objekt @scheme[obj] gültig, wenn der +Vertrag @scheme[contract] für @scheme[(expr obj)] gültig ist. + +(In der Regel ist @scheme[expr] ein Record-Selektor @scheme[s]. In +dem Fall ist der Vertrag @scheme[(property s c)] für alle Records +gültig, bei denen der Wert des zu @scheme[s] gehörigen Felds den +Vertrag @scheme[c] erfüllt.) +} + +@subsection{@scheme[list]} +@defform[(list contract)]{ +Dieser Vertrag ist dann für einen Wert gültig, wenn dieser eine Liste ist, +für dessen Elemente @scheme[contract] gültig ist. +} + +@subsection[#:tag "contract-variable"]{Vertrags-Variablen} +@defform/none[%a] +@defform/none[%b] +@defform/none[%c] +@defform/none[...]{ +Dies ist eine Vertragsvariable: sie steht für einen Vertrag, der für jeden Wert gültig ist. +} + +@subsection{@scheme[combined]} +@defform[(combined contract ...)]{ +Dieser Vertrag ist für einen Wert gültig, wenn er für alle der Verträge +@scheme[contract] gültig ist. +} + +@section{Testfälle} + +@defform[(check-expect expr expr)]{ + +Dieser Testfall überprüft, ob der erste @scheme[expr] den gleichen +Wert hat wie der zweite @scheme[expr], wobei das zweite @scheme[expr] +meist ein Literal ist.} + +@defform[(check-within expr expr expr)]{ + +Wie @scheme[check-expect], aber mit einem weiteren Ausdruck, +der als Wert eine Zahl @scheme[_delta] hat. Der Testfall überprüft, daß jede Zahl im Resultat +des ersten @scheme[expr] maximal um @scheme[_delta] +von der entsprechenden Zahl im zweiten @scheme[expr] abweicht.} + +@defform[(check-error expr expr)]{ + +Dieser Testfall überprüft, ob der erste @scheme[expr] einen Fehler produziert, +wobei die Fehlermeldung der Zeichenkette entspricht, die der Wert des zweiten +@scheme[expr] ist.} + +@section{Parametrische Record-Typ-Definitionen} + +@defform[(define-record-procedures-parametric (t p1 ...) c p (s1 ...))]{ + +Die @scheme[define-record-procedures-parametric] ist wie +@scheme[define-record-procedures] mit dem Unterschied, daß @scheme[t] +an einen @tech{parametrischen Vertrag} gebunden wird: Es muß genauso viele +Parameter @scheme[p1] geben wie Selektoren @scheme[s1]; für diese +Parameter werden die Verträge für die Felder substituiert. + +Beispiel: + +@schemeblock[ +(define-record-procedures-parametric (pare a b) + make-pare pare? + (pare-one pare-two)) +] + +Dann ist @scheme[(pare integer string)] der Vertrag für +@scheme[pare]-Records, bei dem die Felder die Verträge +@scheme[integer] respektive @scheme[string] erfüllen müssen. +} + +@; ---------------------------------------------------------------------- + +@; @section{@scheme[require]} +@; +@; @defform[(require string)]{ +@; +@; Diese Form macht die Definitionen des durch @scheme[string] spezifizierten Moduls +@; verfügbar. Dabei bezieht sich @scheme[string] auf eine Datei relativ zu der Datei, +@; in der die @scheme[require]-Form steht. +@; +@; Dabei ist @scheme[string] leicht eingeschränkt, um Portabilitätsprobleme zu vermeiden: +@; @litchar{/} ist der Separator für Unterverzeichnisse,, @litchar{.} bedeutet das aktuelle +@; Verzeichnis, @litchar{..} meint das übergeordnete Verzeichnis, Pfadelemente +@; können nur @litchar{a} bis @litchar{z} (groß oder klein), +@; @litchar{0} bis @litchar{9}, @litchar{-}, @litchar{_} +@; und @litchar{.} enthalten, und die Zeichenkette kann nicht leer sein oder +@; ein @litchar{/} am Anfang oder Ende enthalten.} +@; +@; +@; @defform/none[#:literals (require lib) +@; (require (lib string string ...))]{ +@; +@; Diese Form macht die Definitionen eines Moduls in einer installierten Bibliothek +@; verfügbar. +@; Der erste +@; @scheme[string] ist der Name der Datei des Moduls, und die restlichen +@; @scheme[string]s bezeichnen die Collection (und Sub-Collection undsoweiter), +@; in der die Datei installiert ist. Jede @scheme[string] ist ebenso eingeschränkt +@; wie bei @scheme[(require string)].} +@; +@; +@; @defform/none[#:literals (require planet) +@; (require (planet string (string string number number)))]{ +@; +@; Diese Form macht ein Modul einer Bibliothek verfügbar, die aus PLaneT +@; kommt.} + +@; ---------------------------------------- + +@section[#:tag "beginner-prim-ops"]{Primitive Operationen} + +@prim-op-defns['(lib "DMdA-beginner.ss" "deinprogramm") #'here '()] diff --git a/collects/deinprogramm/scribblings/DMdA-lib.scrbl b/collects/deinprogramm/scribblings/DMdA-lib.scrbl new file mode 100644 index 0000000000..e372fa50ce --- /dev/null +++ b/collects/deinprogramm/scribblings/DMdA-lib.scrbl @@ -0,0 +1,53 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + (for-label scheme/base + scheme/contract + scheme/class + scheme/gui/base + lang/posn + lang/imageeq + lang/prim)) + +@(define DMdA @italic{Die Macht der Abstraktion}) +@(define (DMdA-ref s) @secref[#:doc '(lib "deinprogramm/scribblings/deinprogramm-langs.scrbl") s]) + +Note: This is documentation for the language levels that go with the +German textbook @italic{@link["http://www.deinprogramm.de/dmda/"]{Die +Macht der Abstraktion}}. + +@title{@bold{DMdA}: Sprachen als Libraries} + +@; ------------------------------------------------------------ +@section{@italic{Die Macht der Abstraktion} - Anfänger} + +@defmodule[deinprogramm/DMdA-beginner] + +Das Modul @schememodname[deinprogramm/DMdA-beginner] implementiert die +Anfängersprache für @|DMdA|; siehe @DMdA-ref["DMdA-beginner"]. + +@; ------------------------------------------------------------ +@section{@italic{Die Macht der Abstraktion}} + +@defmodule[deinprogramm/DMdA-vanilla] + +Das Modul @schememodname[deinprogramm/DMdA-vanilla] implementiert die +Standardsprache für @|DMdA|; siehe @DMdA-ref["DMdA-vanilla"]. + +@; ------------------------------------------------------------ +@section{@italic{Die Macht der Abstraktion} mit Zuweisungen} + +@defmodule[deinprogramm/DMdA-assignments] + +Das Modul @schememodname[deinprogramm/DMdA-assignments] implementiert +die Sprachebene für @|DMdA| mit Zuweisungen und Mutationen; siehe +@DMdA-ref["DMdA-assignments"]. + +@; ------------------------------------------------------------ +@section{@italic{Die Macht der Abstraktion} - fortgeschritten} + +@defmodule[deinprogramm/DMdA-advanced] + +Das Modul @schememodname[deinprogramm/DMdA-advanced] implementiert +die fortgeschrittene Sprachebene für @|DMdA|; siehe +@DMdA-ref["DMdA-advanced"]. diff --git a/collects/deinprogramm/scribblings/DMdA-vanilla.scrbl b/collects/deinprogramm/scribblings/DMdA-vanilla.scrbl new file mode 100644 index 0000000000..69c44c1912 --- /dev/null +++ b/collects/deinprogramm/scribblings/DMdA-vanilla.scrbl @@ -0,0 +1,26 @@ +#lang scribble/doc +@(require scribblings/htdp-langs/common + "std-grammar.ss" + "prim-ops.ss" + (for-label deinprogramm/DMdA-vanilla)) + +@title[#:style 'toc #:tag "DMdA-vanilla"]{Die Macht der Abstraktion} + +This is documentation for the language level @italic{Die Macht der +Abstraktion} to go with the German textbook @italic{Die Macht der +Abstraktion}. + +@declare-exporting[deinprogramm/DMdA-vanilla] + +@schemegrammar*-DMdA[ +#:literals () +() () () +] + +@|prim-nonterms| + +@prim-ops['(lib "DMdA-vanilla.ss" "deinprogramm") #'here] + +@section[#:tag "vanilla-prim-op"]{Primitive Operationen} + +@prim-op-defns['(lib "DMdA-vanilla.ss" "deinprogramm") #'here '()] diff --git a/collects/deinprogramm/scribblings/deinprogramm-langs.scrbl b/collects/deinprogramm/scribblings/deinprogramm-langs.scrbl new file mode 100644 index 0000000000..383f5150b7 --- /dev/null +++ b/collects/deinprogramm/scribblings/deinprogramm-langs.scrbl @@ -0,0 +1,25 @@ +#lang scribble/doc +@(require scribblings/htdp-langs/common) + +@title{Sprachebenen für @italic{Die Macht der Abstraktion}} + +Note: This is documentation for the language levels that go with the +German textbook @italic{@link["http://www.deinprogramm.de/dmda/"]{Die +Macht der Abstraktion}}. + +Die Sprachebenen in diesem Handbuch sind für Verwendung mit dem Buch +the @italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht der +Abstraktion}} gedacht. + +@table-of-contents[] + +@;------------------------------------------------------------------------ + +@include-section["DMdA-beginner.scrbl"] +@include-section["DMdA-vanilla.scrbl"] +@include-section["DMdA-assignments.scrbl"] +@include-section["DMdA-advanced.scrbl"] + +@;------------------------------------------------------------------------ + +@index-section[] diff --git a/collects/deinprogramm/scribblings/info.ss b/collects/deinprogramm/scribblings/info.ss new file mode 100644 index 0000000000..2ac704094a --- /dev/null +++ b/collects/deinprogramm/scribblings/info.ss @@ -0,0 +1,6 @@ +#lang setup/infotab + +(define scribblings '(("deinprogramm-langs.scrbl" (multi-page) (language -14)) + ("ka.scrbl" (multi-page) (other -10)) + ("DMdA-lib.scrbl"))) + diff --git a/collects/deinprogramm/scribblings/ka.scrbl b/collects/deinprogramm/scribblings/ka.scrbl new file mode 100644 index 0000000000..1b5e52a311 --- /dev/null +++ b/collects/deinprogramm/scribblings/ka.scrbl @@ -0,0 +1,349 @@ +#lang scribble/doc + +@(require scribble/manual + scribble/basic + scribble/extract + scheme/class + scheme/contract) + +@title{Konstruktionsanleitungen 1 bis 10} + +This documents the design recipes of the German textbook @italic{Die +Macht der Abstraktion}. + +@table-of-contents[] + +@section{Konstruktion von Prozeduren} + Gehen Sie bei der Konstruktion einer Prozedur in folgender Reihenfolge + vor: +@itemize[ + @item{@bold{Kurzbeschreibung} Schreiben Sie eine einzeilige Kurzbeschreibung.} + @item{@bold{Datenanalyse} Führen Sie eine Analyse der beteiligten Daten + durch. Stellen Sie dabei fest, zu welcher Sorte die Daten gehören, ob + Daten mit Fallunterscheidung vorliegen und ob zusammengesetzte + oder gemischte Daten vorliegen.} + @item{@bold{Vertrag} Wählen Sie einen Namen und schreiben Sie einen Vertrag für die Prozedur.} + @item{@bold{Testfälle} Schreiben Sie einige Testfälle.} + @item{@bold{Gerüst} Leiten Sie direkt aus dem Vertrag das Gerüst der Prozedur her.} + @item{@bold{Schablone} Leiten Sie aus dem Vertrag und der Datenanalyse mit + Hilfe der Konstruktionsanleitungen eine Schablone her.} + @item{@bold{Rumpf} Vervollständigen Sie den Rumpf der Prozedur.} + @item{@bold{Test} Vergewissern Sie sich, daß die Tests erfolgreich laufen.} +] + +@section{Fallunterscheidung} +Wenn ein Argument einer Prozedur zu einer Fallunterscheidung gehört, +die möglichen Werte also in feste Kategorien sortiert werden können, +steht im Rumpf eine Verzweigung. Die Anzahl der Zweige entspricht +der Anzahl der Kategorien. + +Die Schablone für eine Prozedur @scheme[proc], deren Argument zu einer Sorte gehört, +die @italic{n} Kategorien hat, sieht folgendermaßen aus: + +@schemeblock[ +(: proc (ctr -> ...)) +(define proc + (lambda (a) + (cond + (#,(elem (scheme test) (subscript "1")) ...) + ... + (#,(elem (scheme test) (subscript "n")) ...)))) +] +Dabei ist @scheme[ctr] der Vertrag, den die Elemente der Sorte erfüllen müssen. +Die @elem[(scheme test) (subscript "i")] müssen Tests sein, welche die einzelnen Kategorien +erkennen. Sie sollten alle Kategorien abdecken. +Der letzte Zweig kann auch ein @scheme[else]-Zweig sein, falls +klar ist, daß @scheme[a] zum letzten Fall gehört, wenn alle vorherigen +@elem[(scheme test) (subscript "i")] @scheme[#f] ergeben haben. +Anschließend werden die Zweige vervollständigt. + +Bei Fallunterscheidungen mit zwei Kategorien kann auch @scheme[if] +statt @scheme[cond] verwendet werden. + +@section{zusammengesetzte Daten} +Wenn bei der Datenanalyse zusammengesetzte Daten vorkommen, stellen +Sie zunächst fest, welche Komponenten zu welchen Sorten gehören. +Schreiben Sie dann eine Datendefinition, die mit folgenden Worten +anfängt: + +@schemeblock[ +(code:comment #, @t{Ein @scheme[x] besteht aus / hat:}) +(code:comment #, @t{- @scheme[#,(elem (scheme Feld) (subscript "1"))] @scheme[(#,(elem (scheme ctr) (subscript "1")))]}) +(code:comment #, @t{...}) +(code:comment #, @t{- @scheme[#,(elem (scheme Feld) (subscript "n"))] @scheme[(#,(elem (scheme ctr) (subscript "n")))]}) +] + +Dabei ist @scheme[x] ein umgangssprachlicher Name für die Sorte +(``Schokokeks''), die @elem[(scheme Feld) (subscript "i")] sind +umgangssprachliche Namen und kurze Beschreibungen der Komponenten +und die @elem[(scheme ctr) (subscript "i")] die dazugehörigen Verträge. + +Übersetzen Sie die Datendefinition in eine Record-Definition, indem Sie +auch Namen für den Record-Vertrag @scheme[ctr], Konstruktor @scheme[constr], +Prädikat @scheme[pred?] und die Selektoren @elem[(scheme select) (subscript "i")] +wählen: +@schemeblock[ +(define-record-procedures ctr + constr pred? + (#,(elem (scheme select) (subscript "1")) ... #,(elem (scheme select) (subscript "n")))) +] + +Schreiben Sie außerdem einen Vertrag für den Konstruktor der +Form: + +@schemeblock[ +(: constr (#,(elem (scheme ctr) (subscript "1")) ... #,(elem (scheme ctr) (subscript "n")) -> ctr)) +] + +Ggf. schreiben Sie außerdem Verträge für das Prädikat und die Selektoren: + +@schemeblock[ +(: pred? (%a -> boolean)) +(: #,(elem (scheme select) (subscript "1")) (ctr -> #,(elem (scheme ctr) (subscript "1")))) +... +(: #,(elem (scheme select) (subscript "n")) (ctr -> #,(elem (scheme ctr) (subscript "n")))) +] + +@section{zusammengesetzte Daten als Argumente} +Wenn ein Argument einer Prozedur zusammengesetzt ist, stellen Sie +zunächst fest, von welchen Komponenten des Records das Ergebnis der +Prozeduren abhängt. + +Schreiben Sie dann für jede Komponente @scheme[(select a)] in die +Schablone, wobei @scheme[select] der Selektor der Komponente und @scheme[a] der Name +des Parameters der Prozedur ist. + +Vervollständigen Sie die Schablone, indem Sie einen Ausdruck +konstruieren, in dem die Selektor-Anwendungen vorkommen. + +@section{zusammengesetzte Daten als Ausgabe} +Eine Prozedur, die einen neuen zusammengesetzten Wert zurückgibt, +enthält einen Aufruf des Konstruktors des zugehörigen Record-Typs. + +@section{gemischte Daten} +Wenn bei der Datenanalyse gemischte Daten auftauchen, schreiben Sie +eine Datendefinition der Form: + +@schemeblock[ +(code:comment #, @t{Ein @scheme[x] ist eins der Folgenden:}) +(code:comment #, @t{- @elem[(scheme Sorte) (subscript "1")] (@elem[(scheme ctr) (subscript "1")])}) +(code:comment #, @t{...}) +(code:comment #, @t{- @elem[(scheme Sorte) (subscript "n")] (@elem[(scheme ctr) (subscript "n")])}) +(code:comment #, @t{Name: @scheme[ctr]}) +] + +Dabei sind die @elem[(scheme Sorte) (subscript "i")] umgangssprachliche Namen +für die möglichen Sorten, die ein Wert aus diesen gemischten Daten +annehmen kann. Die @elem[(scheme ctr) (subscript "i")] sind die zu den Sorten +gehörenden Verträge. Der Name @scheme[ctr] ist für die Verwendung als +Vertrag. + +Aus der Datendefinition entsteht eine Vertragsdefinition folgender Form: + +@schemeblock[ +(define-contract ctr + (mixed #,(elem (scheme ctr) (subscript "1")) + ... + #,(elem (scheme ctr) (subscript "n")))) +] + +Wenn die Prädikate für die einzelnen Sorten @elem[(scheme pred?) +(subscript "1")] ... @elem[(scheme pred?) (subscript "n")] heißen, hat die +Schablone für eine Prozedur, die gemischte Daten konsumiert, die +folgende Form: + +@schemeblock[ +(: proc (ctr -> ...)) + +(define proc + (lambda (a) + (cond + ((#,(elem (scheme pred?) (subscript "1")) a) ...) + ... + ((#,(elem (scheme pred?) (subscript "n")) a) ...)))) +] + +Die rechten Seiten der Zweige werden dann nach den +Konstruktionsanleitungen der einzelnen Sorten ausgefüllt. + +@section{Listen} + +Eine Prozedur, die eine Liste konsumiert, hat die folgende +Schablone: + +@schemeblock[ +(: proc ((list elem) -> ...)) + +(define proc + (lambda (lis) + (cond + ((empty? lis) ...) + ((pair? lis) + ... (first lis) + ... (proc (rest lis)) ...)))) +] + +Dabei ist @scheme[elem] der Vertrag für die Elemente der Liste. Dies +kann eine Vertragsvariable (@scheme[%a], @scheme[%b], ...) sein, falls +die Prozedur unabhängig vom Vertrag der Listenelemente ist. + +Füllen Sie in der Schablone zuerst den @scheme[empty?]-Zweig aus. +Vervollständigen Sie dann den anderen Zweig unter der Annahme, daß +der rekursive Aufruf @scheme[(proc (rest lis))] das gewünschte +Ergebnis für den Rest der Liste liefert. + +Beispiel: + +@schemeblock[ +(: list-sum ((list number) -> number)) + +(define list-sum + (lambda (lis) + (cond + ((empty? lis) 0) + ((pair? lis) + (+ (first lis) + (list-sum (rest lis))))))) +] + +@section{natürliche Zahlen} + +Eine Prozedur, die natürliche Zahlen konsumiert, hat die folgende +Schablone: + +@schemeblock[ +(: proc (natural -> ...)) + +(define proc + (lambda (n) + (if (= n 0) + ... + ... (proc (- n 1)) ...))) +] + +Füllen Sie in der Schablone zuerst den 0-Zweig aus. Vervollständigen +Sie dann den anderen Zweig unter der Annahme, daß der rekursive Aufruf +@scheme[(proc (- n 1))] das gewünschte Ergebnis für @scheme[n]-1 +liefert. + +Beispiel: + +@schemeblock[ +(: factorial (natural -> natural)) + +(define factorial + (lambda (n) + (if (= n 0) + 1 + (* n (factorial (- n 1)))))) +] + +@section{Prozeduren mit Akkumulatoren} + +Eine Prozedur mit Akkumulator, die Listen konsumiert, hat die +folgende Schablone: + +@schemeblock[ +(: proc ((list elem) -> ...)) + +(define proc + (lambda (lis) + (proc-helper lis z))) + +(define proc-helper + (lambda (lis acc) + (cond + ((empty? lis) acc) + ((pair? lis) + (proc-helper (rest lis) + (... (first lis) ... acc ...)))))) +] + +Hier ist @scheme[proc] der Name der zu definierenden Prozedur und +@scheme[proc-helper] der Name der Hilfsprozedur mit Akkumulator. Der +Anfangswert für den Akkumulator ist der Wert von @scheme[z]. Der +Ausdruck @scheme[(... (first lis) ... acc ...)] +macht aus dem alten Zwischenergebnis @scheme[acc] das neue +Zwischenergebnis. + +Beispiel: + +@schemeblock[ +(: invert ((list %a) -> (list %a))) + +(define invert + (lambda (lis) + (invert-helper lis empty))) + +(define invert-helper + (lambda (lis acc) + (cond + ((empty? lis) acc) + ((pair? lis) + (invert-helper (rest lis) + (make-pair (first lis) acc)))))) +] + +Eine Prozedur mit Akkumulator, die natürliche Zahlen konsumiert, hat die +folgende Schablone: + +@schemeblock[ +(: proc (natural -> ...)) + +(define proc + (lambda (n) + (proc-helper n z))) + +(define proc-helper + (lambda (n acc) + (if (= n 0) + acc + (proc-helper (- n 1) (... acc ...))))) +] + +Dabei ist @scheme[z] das gewünschte Ergebnis für @scheme[n] = 0. Der +Ausdruck @scheme[(... acc ...)] muß den neuen Wert für den +Akkumulator berechnen. + +Beispiel: + +@schemeblock[ +(: ! (natural -> natural)) + +(define ! + (lambda (n) + (!-helper n 1))) + +(define !-helper + (lambda (n acc) + (if (= n 0) + acc + (!-helper (- n 1) (* n acc))))) +] + +@section{gekapselter Zustand} +Falls ein Wert Zustand enthalten soll, schreiben Sie eine +Datendefinition wie bei zusammengesetzten Daten. + +Schreiben Sie dann eine Record-Definition mit +@scheme[define-record-procedures-2] und legen Sie dabei fest, welche +Bestandteile veränderbar sein sollen. Geben Sie Mutatoren für die +betroffenen Felder an. Wenn der Selektor für das Feld @scheme[select] +heißt, sollte der Mutator i.d.R. @scheme[set-select!] heißen. Die Form +sieht folgendermaßen aus, wobei an der Stelle @scheme[k] ein +veränderbares Feld steht: + +@schemeblock[ +(define-record-procedures-2 ctr + constr pred? + (#,(elem (scheme select) (subscript "1")) ... (#,(elem (scheme s) (subscript "k")) #,(elem (scheme mutate) (subscript "k"))) ... #,(elem (scheme s) (subscript "n")))) +] + +In der Schablone für Prozeduren, die den Zustand eines +Record-Arguments @scheme[r] ändern, benutzen Sie den dazugehörigen Mutator +@elem[(scheme mutate) (subscript "k")] Wenn @scheme[a] der Ausdruck für den neuen Wert der Komponente ist, +sieht der Aufruf folgendermaßen aus: @scheme[(#,(elem (scheme mutate) (subscript "k")) r a)]. + +Um mehrere Komponenten in einer Prozedur zu verändern, oder um einen +sinnvollen Rückgabewert nach einer Mutation zu liefern, benutzen Sie +@scheme[begin]. diff --git a/collects/deinprogramm/scribblings/prim-ops.ss b/collects/deinprogramm/scribblings/prim-ops.ss new file mode 100644 index 0000000000..3019dbc5cf --- /dev/null +++ b/collects/deinprogramm/scribblings/prim-ops.ss @@ -0,0 +1,107 @@ +#reader scribble/reader +#lang scheme/base +(require scribblings/htdp-langs/common + scribble/decode + scribble/struct + scribble/scheme + scheme/list + scheme/pretty + syntax/docprovide) + +(provide prim-ops + prim-op-defns) + +(define (maybe-make-table l t) + (if (paragraph? t) + (make-paragraph + (append l (cons " " + (paragraph-content t)))) + (make-table + "prototype" + (list (list (make-flow (list (make-paragraph l))) + (make-flow (list t))))))) + + +(define (typeset-type type) + (let-values ([(in out) (make-pipe)]) + (parameterize ([pretty-print-columns 50]) + (pretty-print type out)) + (port-count-lines! in) + (read-syntax #f in))) + +(define (sort-category category) + (sort + (cadr category) + (lambda (x y) + (string<=? (symbol->string (car x)) + (symbol->string (car y)))))) + + +(define (make-proto func ctx-stx) + (maybe-make-table + (list + (hspace 2) + (to-element (datum->syntax ctx-stx (car func))) + (hspace 1) + ":" + (hspace 1)) + (to-paragraph + (typeset-type (cadr func))))) + +(define (prim-ops lib ctx-stx) + (let ([ops (map (lambda (cat) + (cons (car cat) + (list (cdr cat)))) + (lookup-documentation lib 'procedures))]) + (make-table + #f + (apply + append + (map (lambda (category) + (cons + (list (make-flow + (list + (make-paragraph (list (hspace 1) + (bold (car category))))))) + (map (lambda (func) + (list + (make-flow + (list + (make-proto func ctx-stx))))) + (sort-category category)))) + ops))))) + + +(define (prim-op-defns lib ctx-stx not-in) + (make-splice + (let ([ops (map (lambda (cat) + (cons (car cat) + (list (cdr cat)))) + (lookup-documentation lib 'procedures))] + [not-in-ns (map (lambda (not-in-mod) + (let ([ns (make-base-namespace)]) + (parameterize ([current-namespace ns]) + (namespace-require `(for-label ,not-in-mod))) + ns)) + not-in)]) + (apply + append + (map (lambda (category) + (filter values + (map + (lambda (func) + (let ([id (datum->syntax ctx-stx (car func))]) + (and (not (ormap + (lambda (ns) + (free-label-identifier=? + id + (parameterize ([current-namespace ns]) + (namespace-syntax-introduce (datum->syntax #f (car func)))))) + not-in-ns)) + (let ([desc-strs (cddr func)]) + (defthing/proc + id + (to-paragraph (typeset-type (cadr func))) + desc-strs))))) + (sort-category category)))) + ops))))) diff --git a/collects/deinprogramm/scribblings/std-grammar.ss b/collects/deinprogramm/scribblings/std-grammar.ss new file mode 100644 index 0000000000..9877d6bd2a --- /dev/null +++ b/collects/deinprogramm/scribblings/std-grammar.ss @@ -0,0 +1,91 @@ +#reader scribble/reader +#lang scheme/base +(require scribblings/htdp-langs/common + scribble/decode + (for-label deinprogramm/DMdA-beginner)) + +(provide prim-nonterms + schemegrammar*-DMdA) + +(define ex-str "Dies ist eine Zeichenkette, die \" enthält.") + +(define-syntax-rule (schemegrammar*-DMdA + #:literals (lit ...) + (def-rule ...) + (prod ...) + (expr-rule ...)) + (schemegrammar* + #:literals (define define-record-procedures lambda cond if and or let letrec let* begin + #;require lib planet + check-expect check-within check-error + define-contract : + predicate one-of mixed list %a %b %c + lit ...) + (... [program (code:line def-or-expr ...)]) + [def-or-expr definition + expr + test-case + #;library-require] + [definition #, @scheme[(define id expr)] + #, @scheme[(define-record-procedures id id id (id (... ...)))] + #, @scheme[(define-record-procedures-parametric (id id (... ...)) id id (id (... ...)))] + #, @scheme[(define-contract id contract)] + #, @scheme[(: id contract)] + def-rule ...] + prod ... + [expr #, @scheme[(code:line (expr expr (... ...)) (code:comment #, @seclink["application"]{Prozedurapplikation}))] + #, @scheme[#t] + #, @scheme[#f] + #, @scheme[number] + #, @scheme[string] + #, @scheme[(lambda (id (... ...)) expr)] + #, @scheme[(code:line id (code:comment #, @seclink["id"]{Bezeichner}))] + #, @scheme[(cond (expr expr) (expr expr) (... ...))] + #, @scheme[(cond (expr expr) (... ...) (else expr))] + #, @scheme[(if expr expr)] + #, @scheme[(and expr (... ...))] + #, @scheme[(or expr (... ...))] + #, @scheme[(let ((id expr) (... ...)) expr)] + #, @scheme[(letrec ((id expr) (... ...)) expr)] + #, @scheme[(let* ((id expr) (... ...)) expr) ] + #, @scheme[(begin expr expr (... ...))] + expr-rule ...] + [contract id + #, @scheme[(predicate expr)] + #, @scheme[(one-of expr (... ...))] + #, @scheme[(mixed contract (... ...))] + #, @scheme[(code:line (contract (... ...) -> contract) (code:comment #, @seclink["proc-contract"]{Prozedur-Vertrag}))] + #, @scheme[(list contract)] + #, @scheme[(code:line %a %b %c (code:comment #, @seclink["contract-variable"]{Vertrags-Variable}))] + #, @scheme[(combined contract (... ...))] + #, @scheme[(property expr contract)] + ] + [test-case #, @scheme[(check-expect expr expr)] + #, @scheme[(check-within expr expr expr)] + #, @scheme[(check-error expr expr)]] + #;(... + [library-require #, @scheme[(require string)] + #, @scheme[(require (lib string string ...))] + #, @scheme[(require (planet string package))]]) + (... + [package #, @scheme[(string string number number)]]))) + +(define prim-nonterms + (make-splice + (list + +@t{Ein @scheme[_id] ist eine Folge von Zeichen, die weder Leerzeichen +noch eins der folgenden Zeichen enthält:} + +@t{@hspace[2] @litchar{"} @litchar{,} @litchar{'} @litchar{`} +@litchar{(} @litchar{)} @litchar{[} @litchar{]} +@litchar["{"] @litchar["}"] @litchar{|} @litchar{;} +@litchar{#}} + +@t{Ein @scheme[_number] ist eine Zahl wie z.B. @scheme[123], @scheme[3/2] oder +@scheme[5.5].} + +@t{Ein @scheme[_string] ist eine Zeichenkette, und durch ein Paar von @litchar{"} umschlossen. +So sind z.B. @scheme["abcdef"], +@scheme["This is a string"] und @scheme[#,ex-str] Zeichenketten.} +))) diff --git a/collects/deinprogramm/syntax-checkers.ss b/collects/deinprogramm/syntax-checkers.ss new file mode 100644 index 0000000000..bd83c3c622 --- /dev/null +++ b/collects/deinprogramm/syntax-checkers.ss @@ -0,0 +1,20 @@ +#lang scheme/base + +(provide check-for-id! + check-for-id-list!) + +(define (check-for-id! arg error-msg) + (when (not (identifier? arg)) + (raise-syntax-error #f error-msg arg))) + +(define (check-for-id-list! args error-msg) + (for-each (lambda (arg) + (check-for-id! arg error-msg)) + args) + (cond ((check-duplicate-identifier args) + => (lambda (dup) + (raise-syntax-error + #f + "Bezeichner doppelt gebunden" + args dup))) + (else #t))) diff --git a/collects/deinprogramm/test-suite.ss b/collects/deinprogramm/test-suite.ss new file mode 100644 index 0000000000..1407926fcb --- /dev/null +++ b/collects/deinprogramm/test-suite.ss @@ -0,0 +1,5 @@ +#lang scheme/base + +;; This is a dummy file, meant to be overwritten to install support +;; for the test boxes, when a user installs the test-suite bundle from +;; the DMdA web site. diff --git a/collects/deinprogramm/turtle.ss b/collects/deinprogramm/turtle.ss new file mode 100644 index 0000000000..d54f4c88e4 --- /dev/null +++ b/collects/deinprogramm/turtle.ss @@ -0,0 +1,218 @@ +#lang scheme + +(require mzlib/math + (only-in deinprogramm/image rectangle line overlay image-color? image image-color) + (only-in lang/private/imageeq image?) + deinprogramm/contract/contract-syntax) + +(provide set-color + turn + draw + move + run + sequence + turtle + image + image-color) + + ; used to convert angles + (define pi/180 (/ pi 180)) + + ; convert angle value + ; (: grad->rad (number -> number)) + (define grad->rad + (lambda (grad) + (* pi/180 grad))) + + (define-contract turtle (predicate (lambda (x) + (and (vector? x) + (= (vector-length x) 8) + (number? (vector-ref x 0)) + (number? (vector-ref x 1)) + (number? (vector-ref x 2)) + (number? (vector-ref x 3)) + (number? (vector-ref x 4)) + (image? (vector-ref x 5)) + (image-color? (vector-ref x 6)))))) + + ; This function is only for internal use. + ; (new-turtle-priv h w x y angle img color state) + ; creates a new turtle with hight h, width w. + ; The cursor is at position (x,y) and the view direction + ; is defined by an angle value relative to the vector (1,0) . + ; The two next componets represents the image and the + ; color of the pen. The last component represents an abritary + ; value, that allows to transport state with the turtle. + (: new-turtle-priv (number number number number number image image-color %A -> turtle)) + (define new-turtle-priv + (lambda (h w x y angle img color state) + (vector h w x y angle img color state))) + + + ; (new-turtle h w color) + ; creates a new turtle with the pen color color and sets the + ; width of the image to w and the hight to h. + ; The background of the image is gray and the position of the + ; cursor is (0,0) and the view direction is (1,0). + (: new-turtle (number number image-color -> turtle)) + (define new-turtle + (lambda (h w color) + (let ((x (floor (/ w 2))) + (y (floor (/ h 2)))) + (new-turtle-priv h w x y 0 (rectangle w h "solid" "gray") color #f)))) + + ; (new-turtle-complex h w color bgcolor x y angle) + ; creates a new turtle with the pen color color and sets the + ; width of the image to w and the hight to h. + ; The background of the image is bgcolor and the position of the + ; cursor is (x,y) and the view direction is (1,0) * e^(- i angle). + (: new-turtle (number number image-color image-color number number number -> turtle)) + (define new-turtle-complex + (lambda (h w color bgcolor x y angle) + (new-turtle-priv h w x y angle (rectangle w h "solid" bgcolor) color #f))) + + + ; For internal use only + (: get-h (turtle -> number)) + (define get-h (lambda (t) (vector-ref t 0))) + (: get-w (turtle -> number)) + (define get-w (lambda (t) (vector-ref t 1))) + (: get-x (turtle -> number)) + (define get-x (lambda (t) (vector-ref t 2))) + (: get-y (turtle -> number)) + (define get-y (lambda (t) (vector-ref t 3))) + (: get-angle (turtle -> number)) + (define get-angle (lambda (t) (vector-ref t 4))) + (: get-iamge (turtle -> image)) + (define get-image (lambda (t) (vector-ref t 5))) + (: get-color (turtle -> image-color)) + (define get-color (lambda (t) (vector-ref t 6))) + (: get-state (turtle -> %A)) + (define get-state (lambda (t) (vector-ref t 7))) + + ; (set-color color) + ; returns a function of type turtle -> turtle. + ; Use the result to change the color of the pen. + (: set-color (image-color -> (turtle -> turtle))) + (define set-color + (lambda (color) + (lambda (t) + (let* ((h (get-h t)) + (w (get-w t)) + (x (get-x t)) + (y (get-y t)) + (angle (get-angle t)) + (image (get-image t))) + (new-turtle-priv h w x y angle image color #f))))) + + ; (turn angle) + ; returns a function of type turtle -> turtle. + ; Use the result to turn the view of the turtle (counter-clockwise). + (: turn (number -> (turtle -> turtle))) + (define turn + (lambda (grad) + (lambda (t) + (let* ((h (get-h t)) + (w (get-w t)) + (x (get-x t)) + (y (get-y t)) + (angle (get-angle t)) + (image (get-image t)) + (color (get-color t)) + (state (get-state t))) + (new-turtle-priv h w x y (- angle grad) image color state))))) + + ; For internal use only + ; (move-cursor turtle length) + ; returns a new turtle where the cursor + ; is moved length steps along the view vector. + (: move-cursor (turtle number -> turtle)) + (define move-cursor + (lambda (t length) + (let* ((h (get-h t)) + (w (get-w t)) + (x (get-x t)) + (y (get-y t)) + (angle (get-angle t)) + (image (get-image t)) + (color (get-color t)) + (state (get-state t)) + (newx (+ x (* length (cos (grad->rad angle))))) + (newy (+ y (* length (sin (grad->rad angle)))))) + (new-turtle-priv h w newx newy angle image color state)))) + + ; (draw length) + ; returns a function of type turtle -> turtle. + ; The result can be used to move the turtle and draw a line. + (: draw (number -> (turtle -> turtle))) + (define draw + (lambda (length) + (lambda (t) + (let* ((h (get-h t)) + (w (get-w t)) + (x (get-x t)) + (y (get-y t)) + (angle (get-angle t)) + (image (get-image t)) + (color (get-color t)) + (state (get-state t)) + ; Compute new coordinats + (newx (+ x (* length (cos (grad->rad angle))))) + (newy (+ y (* length (sin (grad->rad angle)))))) + (new-turtle-priv + h w + newx newy angle + ; Compute new image + (overlay image + (line w h x y newx newy color) 0 0) + color state))))) + + ; (move length) + ; returns a function of type turtle -> turtle. + ; The result can be used to move the turtle without drawing a line. + (: move (number -> (turtle -> turtle))) + (define move + (lambda (length) + (lambda (t) + (move-cursor t length)))) + + ; runs a turtle function + (: run ((turtle -> turtle) number number image-color -> image)) + (define run + (lambda (t->t h w color) + (get-image (t->t (new-turtle h w color))))) + +; ; runs a turtle function +; ; (: run* ((turtle -> turtle) -> turtle -> image)) +; (define run* +; (lambda (t->t h w color bgcolor x y angle) +; (get-image (t->t (new-turtle h w color bgcolor x y angle))))) + + ; This function is only for internal use. + (define comp_priv_2 + (lambda (f1 f2) + (lambda (t) + (f2 (f1 t))))) + + ; This function is only for internal use. + (define comp_priv + (lambda (l) + (cond + ((null? l) (error "sequence erwartet mind. ein Argument")) + ((list? l) + (let ((head (car l)) + (tail (cdr l))) + (if (null? tail) + head + (comp_priv_2 head (comp_priv tail)))))))) + + ; This function allows to do a list of + ; turtle -> turtle + ; functions into one new function, that do + ; one action of the turtle, then later the rest. + ; Define the type alias tip = turtle -> turtle. + (define-contract tip (turtle -> turtle)) + (: do (tip ... -> tip)) + (define sequence (lambda l (comp_priv l))) + + diff --git a/collects/deinprogramm/world.ss b/collects/deinprogramm/world.ss new file mode 100644 index 0000000000..daf25073b8 --- /dev/null +++ b/collects/deinprogramm/world.ss @@ -0,0 +1,321 @@ +#lang scheme/base + +;; Mon Mar 27 10:29:28 EST 2006: integrated Felix's mouse events +;; Wed Jan 25 13:38:42 EST 2006: on-redraw: proc is now called on installation +;; Tue Jan 3 11:17:50 EST 2006: changed add-line behavior in world.ss +;; Sat Dec 10 19:39:03 EST 2005: fixed name, changed interface to on-key-event +;; Fri Dec 9 21:39:03 EST 2005: remoevd (update ... produce ...); added on-redraw +;; Thu Dec 1 17:03:03 EST 2005: fixed place-image; all coordinates okay now + + (require + mred + mzlib/class + htdp/error + "image.ss" + (prefix-in beg: lang/htdp-beginner) + lang/prim + deinprogramm/contract/contract-syntax) + + ;; --- provide --------------------------------------------------------------- + (provide (all-from-out "image.ss")) + + (provide ;; forall(World): + big-bang ;; Number Number Number World -> true + end-of-time ;; String u Symbol -> World + + place-image ;; Image Number Number Scence -> Scene + empty-scene ;; Number Number -> Scene + run-movie ;; (Listof Image) -> true + ) + + (provide-higher-order-primitive + on-tick-event (tock) ;; (World -> World) -> true + ) + + (provide-higher-order-primitive + on-redraw (world-image) ;; (World -> Image) -> true + ) + + ;; KeyEvent is one of: + ;; -- Char + ;; -- Symbol + + (provide-higher-order-primitive ;; (World KeyEvent -> World) -> true + on-key-event + (draw) + ) + + ;; A MouseEventKind is one of: + ;; "enter" -- mouse pointer entered the window + ;; "leave" -- mouse pointer left the window + ;; "left-down" -- left mouse button pressed + ;; "left-up" -- left mouse button released + ;; "middle-down" -- middle mouse button pressed + ;; "middle-up" -- middle mouse button released + ;; "right-down" -- right mouse button pressed (Mac OS: click with control key pressed) + ;; "right-up" -- right mouse button released (Mac OS: release with control key pressed) + ;; "motion" -- mouse moved, with or without button(s) pressed + + + (provide-higher-order-primitive ;; (World Number Number MouseEventKind -> World) -> true + on-mouse-event + (clack) + ) + + (provide mouse-event-kind) + + (define-contract mouse-event-kind (one-of "enter" "leave" "motion" "left-down" "left-up" "middle-down" "middle-up" "right-down" "right-up")) + + ;; --------------------------------------------------------------------------- + + ;; Symbol Any String -> Void + (define (check-pos tag c rank) + (check-arg tag (and (number? c) (integer? c) (>= c 0)) "positive integer" rank c)) + + ;; Symbol Any String [String] -> Void + (define (check-image tag i rank . other-message) + (if (and (pair? other-message) (string? (car other-message))) + (check-arg tag (beg:image? i) (car other-message) rank i) + (check-arg tag (beg:image? i) "image" rank i))) + + ;; Symbol Any String -> Void + (define (check-color tag width rank) + (check-arg tag (or (symbol? width) (string? width)) "color symbol or string" rank width)) + + (define (check-mode tag s rank) + (check-arg tag (or (eq? s 'solid) + (eq? s 'outline) + (string=? "solid" s) + (string=? "outline" s)) "mode (solid or outline)" rank s)) + + (define (place-image image x y scene) + (check-image 'place-image image "first") + (check-arg 'place-image (and (number? x) (real? x)) 'number "second" x) + (check-arg 'place-image (and (number? y) (real? x)) 'number "third" y) + (check-image 'place-image scene "fourth" "scene") + (let () + (define sw (image-width scene)) + (define sh (image-height scene)) + (define ns (overlay scene image x y)) + (define nw (image-width ns)) + (define nh (image-height ns)) + (if (and (= sw nw) (= sh nh)) + ns + (clip ns 0 0 sw sh)))) + + (define (empty-scene width height) + (check-pos 'empty-scene width "first") + (check-pos 'empty-scene height "second") + (rectangle width height 'outline 'black) + ) + + ;; display all images in list in the canvas + (define (run-movie movie) + (check-arg 'run-movie (list? movie) "list (of images)" "first" movie) + (for-each (lambda (cand) (check-image 'run-movie cand "first" "list of images")) + movie) + (let run-movie ([movie movie]) + (cond [(null? movie) #t] + [(pair? movie) + (update-frame (car movie)) + (sleep/yield .05) + (run-movie (cdr movie))]))) + + ;; --------------------------------------------------------------------------- + + ;; The One and Only Visible World + (define the-frame #f) + (define txt (new text%)) + + ;; World (type parameter) + (define the-world0 (cons 1 1)) + [define the-world the-world0] + + (define (check-world tag) + (when (eq? the-world0 the-world) (error tag SEQUENCE-ERROR))) + + ;; Number > 0 + [define the-delta 1000] + + ;; Amount of space around the image in the world window: + (define INSET 5) + + ;; Number Number Number World -> true + ;; create the visible world (canvas) + (define (big-bang w h delta world) + (check-pos 'big-bang w "first") + (check-pos 'big-bang h "second") + (check-arg 'big-bang + (and (number? delta) (<= 0 delta 1000)) + "number [of seconds] between 0 and 1000" + "first" + delta) + (when the-frame (error 'big-bang "big-bang already called once")) + (set! the-delta delta) + (set! the-world world) + (set! the-frame + (new (class frame% + (super-new) + (define/augment (on-close) + ;; shut down the timer when the window is destroyed + (send the-time stop) + (inner (void) on-close))) + (label "DrScheme") + (stretchable-width #f) + (stretchable-height #f) + (style '(no-resize-border metal)))) + (let ([c (new (class editor-canvas% + (super-new) + (define/override (on-char e) + (on-char-proc (send e get-key-code))) + (define/override (on-event e) + (on-mouse-proc e))) + (parent the-frame) + (editor txt) + (style '(no-hscroll no-vscroll)) + (horizontal-inset INSET) + (vertical-inset INSET))]) + (send c min-client-width (+ w INSET INSET)) + (send c min-client-height (+ h INSET INSET)) + (send c focus)) + (send txt set-cursor (make-object cursor% 'arrow)) + (send txt hide-caret #t) + (send the-frame show #t) + #t) + + ;; --- time events + [define the-time (new timer% [notify-callback (lambda () (timer-callback))])] + + ;; (World -> World) + [define timer-callback void] + + [define (on-tick-event f) + (check-proc 'on-tick-event f 1 "on-tick-event" "one argument") + (check-world 'on-tick-event) + (if (eq? timer-callback void) + (set! timer-callback + (lambda () + (with-handlers ([exn:break? break-handler] + [exn? exn-handler]) + (set! the-world (f the-world)) + (on-redraw-proc)))) + (error 'on-tick "the timing action has been set already")) + (send the-time start + (let* ([w (ceiling (* 1000 the-delta))]) + (if (exact? w) w (inexact->exact w)))) + #t] + + ;; --- key and mouse events + + ;; KeyEvent -> Void + [define on-char-proc void] + + [define (on-key-event f) + (check-proc 'on-key-event f 2 "on-key-event" "two arguments") + (check-world 'on-key-event) + (let ([esp (current-eventspace)]) + (if (eq? on-char-proc void) + (begin + (set! on-char-proc + (lambda (e) + (cond + ((event->string e) + => (lambda (s) + (parameterize ([current-eventspace esp]) + (queue-callback + (lambda () + (with-handlers ([exn:break? break-handler] + [exn? exn-handler]) + (set! the-world (f the-world s)) + (on-redraw-proc)))))))) + #t)) + #t) + (error 'on-event "the event action has been set already")))] + + (define (event->string e) + (if (char? e) + (string e) + (case e + ((left) "left") + ((right) "right") + ((up) "up") + ((down) "down") + ((wheel-up) "wheel-up") + ((wheel-down) "wheel-down") + (else #f)))) + + [define (end-of-time s) + (printf "end of time: ~a~n" s) + (stop-it) + the-world] + + ;; MouseEvent -> Void + [define on-mouse-proc void] + + [define (on-mouse-event f) + (check-proc 'on-mouse-event f 4 "on-mouse-event" "four arguments") + (check-world 'on-mouse-event) + (let ([esp (current-eventspace)]) + (if (eq? on-mouse-proc void) + (begin + (set! on-mouse-proc + (lambda (e) + (parameterize ([current-eventspace esp]) + (queue-callback + (lambda () + (with-handlers ([exn:break? break-handler] + [exn? exn-handler]) + (set! the-world (f the-world + (send e get-x) + (send e get-y) + (symbol->string (send e get-event-type)))) + (on-redraw-proc)))) + #t))) + #t) + (error 'on-mouse-event "the mouse event action has been set already")))] + + ;; --- library + [define (exn-handler e) + (send the-time stop) + (set! on-char-proc void) + (set! timer-callback void) + (raise e)] + + [define (break-handler . _) + (printf "animation stopped") + (stop-it) + the-world] + + ;; -> Void + (define (stop-it) + (send the-time stop) + (set! on-char-proc void) + (set! timer-callback void)) + + (define on-redraw-proc void) + + (define (on-redraw f) + (check-proc 'on-redraw f 1 "on-redraw" "one argument") + (check-world 'on-redraw) + (if (eq? on-redraw-proc void) + (begin + (set! on-redraw-proc + (lambda () + (with-handlers ([exn:break? break-handler] + [exn? exn-handler]) + (define img (f the-world)) + (check-result 'on-redraw (lambda (x) (beg:image? x)) "image" img) + (update-frame img) + #t))) + (on-redraw-proc)) + (error 'on-redraw "the redraw function has already been specified"))) + + (define (update-frame pict) + (send txt begin-edit-sequence) + (send txt lock #f) + (send txt delete 0 (send txt last-position) #f) + (send txt insert (send pict copy) 0 0 #f) + (send txt lock #t) + (send txt end-edit-sequence)) + + (define SEQUENCE-ERROR "evaluate (big-bang Number Number Number World) first") diff --git a/collects/teachpack/deinprogramm/image.ss b/collects/teachpack/deinprogramm/image.ss new file mode 100644 index 0000000000..e6c29e7eff --- /dev/null +++ b/collects/teachpack/deinprogramm/image.ss @@ -0,0 +1,3 @@ +(module image mzscheme + (require (lib "image.ss" "deinprogramm")) + (provide (all-from (lib "image.ss" "deinprogramm")))) diff --git a/collects/teachpack/deinprogramm/line3d.ss b/collects/teachpack/deinprogramm/line3d.ss new file mode 100644 index 0000000000..49cfc6dcfd --- /dev/null +++ b/collects/teachpack/deinprogramm/line3d.ss @@ -0,0 +1,3 @@ +(module line3d mzscheme + (provide (all-from (lib "line3d.ss" "deinprogramm"))) + (require (lib "line3d.ss" "deinprogramm"))) \ No newline at end of file diff --git a/collects/teachpack/deinprogramm/scribblings/deinprogramm.scrbl b/collects/teachpack/deinprogramm/scribblings/deinprogramm.scrbl new file mode 100644 index 0000000000..ff415fcf71 --- /dev/null +++ b/collects/teachpack/deinprogramm/scribblings/deinprogramm.scrbl @@ -0,0 +1,18 @@ +#lang scribble/doc + +@(require scribble/manual + (for-label scheme)) + +@title[#:style '(toc) #:tag "deinprogramm"]{DeinProgramm-Teachpacks} + +Note: This is documentation for the teachpacks that go with the German +textbook @italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht +der Abstraktion}}. + +@table-of-contents[] + +@include-section["image.scrbl"] +@include-section["world.scrbl"] +@include-section["turtle.scrbl"] +@include-section["sound.scrbl"] +@include-section["line3d.scrbl"] diff --git a/collects/teachpack/deinprogramm/scribblings/image.scrbl b/collects/teachpack/deinprogramm/scribblings/image.scrbl new file mode 100644 index 0000000000..f62cd56dce --- /dev/null +++ b/collects/teachpack/deinprogramm/scribblings/image.scrbl @@ -0,0 +1,197 @@ +#lang scribble/doc + +@(require scribble/manual "shared.ss" + (for-label scheme + teachpack/deinprogramm/image)) + +@teachpack["image"]{Bilder konstruieren} + +Note: This is documentation for the @tt{image.ss} teachpack that goes +with the German textbook +@italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht der +Abstraktion}}. + +@declare-exporting[teachpack/deinprogramm/image #:use-sources (deinprogramm/image)] + +Dieses Teachpack definiert Prozeduren für die Konstruktion von Bildern. +Einfache Bilder werden als geometrische Formen oder Bitmaps konstruiert. +Zusätzliche Prozeduren erlauben die Komposition von Bildern. + +@;----------------------------------------------------------------------------- +@section{Bilder} + +@declare-exporting[teachpack/deinprogramm/image] + +@defthing[image contract]{ +Ein @deftech{Bild} (Name: @scheme[image]) ist die Repräsentation eines Bildes. +} + +@defthing[empty-image image]{ +Ein leeres Bild mit Breite und Höhe 0. +} + +@defthing[image? (%a -> boolean?)]{Der Aufruf @scheme[(image? x)] stellt fest, ob @scheme[x] ein Bild ist.} + +@;----------------------------------------------------------------------------- +@section[#:tag "modes-colors"]{Modi und Farben} + +@defthing[mode contract]{ +@scheme[(one-of "solid" "outline")] + +Ein Modus (Name: @scheme[mode]) legt fest, ob die Darstellung einer Form diese füllt +oder nur einen Umriss zeichnet.} + +@defthing[octet contract]{ +@scheme[(combined natural (predicate (lambda (n) (<= n 255))))] + +Ein Oktet (Name: @scheme[octet]) ist eine natürliche Zahl zwischen 0 und 255.} + +@defthing[rgb-color contract]{ +Eine @deftech{RGB-Farbe} ist eine Farbe (Name: @scheme[color], die vom +Record-Konstruktor @scheme[make-color] zurückgegeben wird: +} + +@defthing[make-color (octet octet octet -> rgb-color)]{ +Eine @tech{RGB-Farbe} beschreibt eine Farbe mit den roten, blauen und grünen Anteilen, +also z.B. @scheme[(make-color 100 200 30)].} + +@defthing[color-red (color -> octet)]{ + liefert den Rot-Anteil einer RGB-Farbe.} +@defthing[color-green (color -> octet)]{ + liefert den Grün-Anteil einer RGB-Farbe.} +@defthing[color-blue (color -> octet)]{ + liefert den Blau-Anteil einer RGB-Farbe.} + +@defthing[image-color contract]{ +@scheme[(mixed string color)] + +Eine @deftech{Farbe} (Name: @scheme[image-color]) ist eine Zeichenkette aus einer Farbbezeichnung +(z.B. @scheme["blue"]) oder eine @tech{RGB-Farbe}.} + +@defthing[image-color? (%a -> boolean?)]{ stellt fest, ob ein Objekt +eine @tech{Farbe} ist.} + + +@;----------------------------------------------------------------------------- +@section[#:tag "creational"]{Einfache geometrische Figuren} + +Die folgenden Prozeduren erzeugen Bilder mit einfachen geometrischen Formen: + +@defthing[rectangle (natural natural mode image-color -> image)]{ + Der Aufruf @scheme[(rectangle w h m c)] + erzeugt ein Rechteck mit Breite @scheme[w] und Höhe @scheme[h], gefüllt mit Modus + @scheme[m] und in Farbe @scheme[c].} + +@defthing[circle (natural mode image-color -> image)]{ + Der Aufruf @scheme[(circle r m c)] + erzeugt einen Kreis oder eine Scheibe mit Radius @scheme[r], gefüllt mit Modus + @scheme[m] und in Farbe @scheme[c].} + +@defthing[ellipse (natural natural mode image-color -> image)]{ + Der Aufruf @scheme[(ellipse w h m c)] + erzeugt eine Ellipse mit Breite @scheme[w] und Höhe @scheme[h], gefüllt mit Modus + @scheme[m] uns in Farbe @scheme[c].} + +@defthing[triangle (integer mode image-color -> image)]{ + Der Aufruf @scheme[(triangle s m c)] + erzeugt ein nach oben zeigendes gleichseitiges Dreieck, wobei + @scheme[s] die Seitenlänge angibt, gefüllt mit Modus + @scheme[m] uns in Farbe @scheme[c].} + +@defthing[line (natural natural number number number number image-color -> image)]{ + Der Aufruf @scheme[(line w h sx sy ex ey c)] + erzeugt ein Bild mit einer farbigen Strecke, wobei @scheme[w] die Breite und @scheme[h] die Höhe des Bilds, + sowie @scheme[sx] die X- und @scheme[sx] die Y-Koordinate des Anfangspunkts und + @scheme[ex] die X- und @scheme[ey] die Y-Koordinate des Endpunkts angeben, gefüllt mit Modus + @scheme[m] uns in Farbe @scheme[c].} + +@defthing[text (string natural image-color -> image)]{ + Der Aufruf @scheme[(text s f c)] + erzeugt ein Bild mit Text @scheme[s], + wobei die Buchstaben die Größe @scheme[f] haben, in Farbe @scheme[c]} + +Außerdem können beliebige Bitmap-Bilder in ein Scheme-Programm +eingeklebt werden. + +@;----------------------------------------------------------------------------- +@section[#:tag "properties"]{Eigenschaften von Bildern} + +Zwei Eigenschaften von Bildern sind für ihre Manipulation nützlich, +nämlich Breite und Höhe: + +@defthing[image-width (image -> natural)]{ + liefert die Breite von @scheme[i] in Pixeln.} + +@defthing[image-height (image -> natural)]{ + liefert die Höhe von @scheme[i] in Pixeln.} + +@;----------------------------------------------------------------------------- +@section[#:tag "composition"]{Bilder zusammensetzen} + +The nächste Gruppe von Prozeduren baut aus Bildern neue Bilder: + +@defthing[h-place contract]{ +@scheme[(mixed integer (one-of "left" "right" "center"))] + +Eine @deftech{horizontale Positionsangabe} (Name: @scheme[h-place]) +gibt an, wie zwei Bilder horizontal zueinander positioniert werden + +Im ersten Fall, wenn es sich um eine Zahl @scheme[x] handelt, wird das +zweite Bild @scheme[x] Pixel vom linken Rand auf das erste gelegt. +Die drei Fälle mit Zeichenketten sagen, daß die Bilder am linken Rand +bzw. am rechten Rand bündig plaziert werden, bzw. das zweite Bild +horizontal in die Mitte des ersten gesetzt wird.} + +@defthing[v-place contract]{ +@scheme[(mixed integer (one-of "top" "bottom" "center"))] + +Eine @deftech{vertikale Positionsangabe} (Name: @scheme[v-place]) +gibt an, wie zwei Bilder vertikal zueinander positioniert werden + +Im ersten Fall, wenn es sich um eine Zahl @scheme[y] handelt, wird das +zweite Bild @scheme[y] Pixel vom oberen Rand auf das erste gelegt. +Die drei Fälle mit Zeichenketten sagen, daß die Bilder am oberen Rand +bzw. am unteren Rand bündig plaziert werden, bzw. das zweite Bild +vertikal in die Mitte des ersten gesetzt wird. +} + +@defthing[h-mode contract]{ +@scheme[(one-of "left" "right" "center")] +Eine @deftech{horizontale Justierungsangabe} (Name: @scheme[h-mode]) +gibt an, ob zwei Bilder, die übereinander angeordnet werden, entlang der linken +Kante, der rechten Kante oder der Mitte angeordnet werden. +} + +@defthing[v-mode contract]{ +@scheme[(one-of "top" "bottom" "center")] + +Eine @deftech{vertikale Justierungsangabe} (Name: @scheme[V-mode]) +gibt an, ob zwei Bilder, die nebenander angeordnet werden, entlang der +oberen Kante, der untern Kante oder der Mitte angeordnet werden.} + +@defthing[overlay (image image h-place v-place -> image)]{ + Der Aufruf @scheme[(overlay img other h v)] + legt zweite Bild @scheme[img] auf das erste @scheme[other]. Die beiden anderen Argumente geben an, wie + die beiden Bilder zueinander positioniert werden.} + +@defthing[beside (image image v-mode -> image)]{ + Der Aufruf @scheme[(beside img other v)] + ordnet die beiden Bilder entsprechend des @scheme[v]-Arguments + nebeneinander an.} + +@defthing[above (image image h-mode -> image)]{ + Der Aufruf @scheme[(img other h -> image)] + ordnet die beiden Bilder entsprechend des @scheme[h]-Arguments + übereinander an.} + +@defthing[clip (image natural natural natural natural -> image)]{ + Der Aufruf @scheme[(clip img x y w h)] + liefert das Teilrechteck des Bildes @scheme[img] + bei (@scheme[x], @scheme[y]), Breite @scheme[w] und Höhe @scheme[h].} + +@defthing[pad (image natural natural natural natural -> image)]{ + Der Aufruf @scheme[(pad img l r t b)] + fügt an den Seiten von @scheme[img] noch transparenten Leerraum an: + @scheme[l] Pixel links, @scheme[r] Pixel rechts, @scheme[t] Pixel oben und + @scheme[b] Pixel unten.} + diff --git a/collects/teachpack/deinprogramm/scribblings/info.ss b/collects/teachpack/deinprogramm/scribblings/info.ss new file mode 100644 index 0000000000..3bae7dc50b --- /dev/null +++ b/collects/teachpack/deinprogramm/scribblings/info.ss @@ -0,0 +1,3 @@ +#lang setup/infotab + +(define scribblings '(("deinprogramm.scrbl" (multi-page) (library -10)))) diff --git a/collects/teachpack/deinprogramm/scribblings/line3d.scrbl b/collects/teachpack/deinprogramm/scribblings/line3d.scrbl new file mode 100644 index 0000000000..5d7ffabd0c --- /dev/null +++ b/collects/teachpack/deinprogramm/scribblings/line3d.scrbl @@ -0,0 +1,240 @@ +#lang scribble/doc + +@(require scribble/manual "shared.ss" + (for-label scheme + teachpack/deinprogramm/image + teachpack/deinprogramm/line3d)) + +@teachpack["line3d"]{3D-Liniengraphik} + +Note: This is documentation for the @tt{line3d.ss} teachpack that goes +with the German textbook +@italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht der +Abstraktion}}. + +@declare-exporting[teachpack/deinprogramm/line3d #:use-sources (teachpack/deinprogramm/line3d)] + +Dieses teachpack definiert Prozeduren für lineare Algebra und 3D-Rendering: + +@;---------------------------------------------------------------------------------- +@section[#:tag "rendering"]{Szenen erzeugen} + +@declare-exporting[teachpack/deinprogramm/line3d] + +@defthing[render-scene (natural natural (list line3d) matrix4x4 -> image)]{ + Der Aufruf @scheme[(render-scene width height scene camera-matrix)]erzeugt die Szene + in ein Bild mit Breite @scheme[width] und Höhe @scheme[height]. Position, + Orientierung und Projektion werden durch die @scheme[camera-matrix] festgelegt. +} + +@defthing[create-camera-matrix (vec3 vec3 number natural natural -> matrix4x4)]{ + Der Aufruf @scheme[(create-camera-matrix position lookat vertical-fov width height)] + erzeugt eine 4x4 Matrix. Diese kodiert eine Kamera an der Position @scheme[position], die + auf die Position @scheme[lookat] schaut. + @scheme[vertical-fov] bezeichnet das @deftech{vertikale Feld} der Szene. +} + +Zum Beispiel: + +@schemeblock[ +(code:comment #, @t{scene-data (simple box example)}) +(define box + (create-box 1.0 1.0 1.0 "brown")) +(code:comment #, @t{screen}) +(define screenWidth 320) +(define screenHeight 240) +(code:comment #, @t{camera}) +(define pos (make-vec3 5 5 3)) +(define lookat (make-vec3 0 0 0)) +(define camera + (create-camera-matrix pos lookat 70.0 screenWidth screenHeight)) +(code:comment #, @t{render image}) +(render-scene screenWidth screenHeight box camera) +] + +@;------------------------------------------------------------------------------------- +@section[#:tag "3Dvectors"]{3D-Vektoren} + +@defthing[vec3 contract]{ + Ein @deftech{3D-Vektor} (Name: @scheme[vec3]) ist ein Record, der durch den Aufruf @scheme[make-vec3] erstellt wird. +} + +@defthing[make-vec3 (number number number -> vec3)]{ + @scheme[(make-vec3 x y z)] erstellt einen Vektor (x,y,z). +} + +@defthing[add-vec3 (vec3 vec3 -> vec3)]{ + @scheme[(add-vec3 a b)] gibt die Summe von @scheme[a] und @scheme[b] zurück. +} + +@defthing[sub-vec3 (vec3 vec3 -> vec3)]{ + @scheme[(sub-vec3 a b)] gibt die Differenz zwischen @scheme[a] und @scheme[b] zurück. +} + +@defthing[mult-vec3 (vec3 number -> vec3)]{ + @scheme[(mult-vec3 a s)] gibt den das Produkt von @scheme[a] und @scheme[s] zurück. +} + +@defthing[div-vec3 (vec3 number -> vec3)]{ + @scheme[(div-vec3 a s)] gibt den das Produkt von @scheme[a] und dem Kehrwert von @scheme[s] zurück. +} + +@defthing[dotproduct-vec3 (vec3 vec3 -> number)]{ + @scheme[(dotproduct-vec3 a b)] gibt das Produkt von @scheme[a] und @scheme[b] zurück. +} + +@defthing[normQuad-vec3 (vec3 -> number)]{ + @scheme[(normQuad-vec3 a)] gibt die quadrierte Norm/Länge |@scheme[a]|² eines Vektors @scheme[a] zurück (Quadrat der Euklidischen Norm.) +} + +@defthing[norm-vec3 (vec3 -> number)]{ + @scheme[(norm-vec3 a)] gibt die Norm/Länge |@scheme[a]| eines Vektors a zurück (Euklidische Norm.) +} + +@defthing[normalize-vec3 (vec3 -> vec3)]{ + @scheme[(normalize-vec3 a)] normalisiert @scheme[a]. +} + +@defthing[crossproduct-vec3 (vec3 vec3-> vec3)]{ + @scheme[(crossproduct-vec3 a b)] gibt das Kreuzprodukt von @scheme[a] +und @scheme[b] zurück (einen Vektor der senkrecht auf @scheme[a] und @scheme[b] steht). +} + +@;------------------------------------------------------------------------------------- +@section[#:tag "4Dvectors"]{4D-Vektoren} + +@defthing[vec4 contract]{ + Ein @deftech{4D-Vektor} @scheme[vec4] ist ein 4D-Vektor. Folgende Prozeduren werden bereitgestellt: +} + +@defthing[make-vec4 (number number number number -> vec4)]{ + @scheme[(make-vec4 a b c d)] erzeugt einen Vektor aus @scheme[a], @scheme[b], @scheme[c] und @scheme[d]. +} + +@defthing[add-vec4 (vec4 vec4 -> vec4)]{ +@scheme[(add-vec4 a b)] gibt die Summe von @scheme[a] und @scheme[b] zurück. +} + +@defthing[sub-vec4 (vec4 vec4 -> vec4)]{ + @scheme[(sub-vec4 a b)] gibt die Differenz zwischen @scheme[a] und @scheme[b] zurück. +} + +@defthing[mult-vec4 (vec4 number -> vec4)]{ + @scheme[(mult-vec4 a s)] gibt den das Produkt von @scheme[a] und @scheme[s] zurück. +} + +@defthing[div-vec4 (vec4 number -> vec4)]{ + @scheme[(div-vec4 a s)] gibt den das Produkt von @scheme[a] und dem Kehrwert von @scheme[s] zurück. +} + +@defthing[dotproduct-vec4 (vec3 vec4 -> number)]{ + @scheme[(dotproduct-vec4 a b)] gibt die quadrierte Norm/Länge |@scheme[a]|² eines Vektors @scheme[a] zurück (Quadrat der Euklidischen Norm.) +} + +@defthing[normQuad-vec4 (vec4 -> number)]{ + @scheme[(normQuad-vec4 a)] gibt die quadrierte Norm/Länge |@scheme[a]|² eines Vektors @scheme[a] zurück (Quadrat der Euklidischen Norm.) +} + +@defthing[norm-vec4 (vec4 -> number)]{ + @scheme[(norm-vec4 a)] gibt die Norm/Länge |a| eines Vektors a zurück (Euklidische Norm) +} + +@defthing[normalize-vec4 (vec4 -> vec4)]{ + @scheme[(normalize-vec4 a)] normalisiert @scheme[a]. +} + +@defthing[expand-vec3 (vec3 number -> vec4)]{ + @scheme[(expand-vec3 a s)] gibt den 4D-Vektor mit @scheme[s] als letze Komponente zurück (erweitert @scheme[a] mit @scheme[s]). +} + +@;------------------------------------------------------------------------------------- +@section[#:tag "4x4matrix"]{4x4 Matrizen} + +@defthing[matrix4x4 contract]{ + Eine @deftech{Matrix} @scheme[matrix4x4] ist ein Record, der durch den Aufruf @scheme[make-matrix4x4] erstellt wird. +} + +@defthing[make-matrix4x4 (vec4 vec4 vec4 vec4 -> matrix4x4)]{ + @scheme[(make-matrix4x4 a b c d)] erstellt eine Matrix aus @scheme[a], @scheme[b], @scheme[c] und @scheme[d]. +} + +@defthing[create-matrix4x4 (vec3 vec3 vec3 vec3 -> matrix4x4)]{ + @scheme[(create-matrix4x4 a b c d)] erweitert jeden Vektor in einen 4D-Vektor und kombiniert diese zu + einer Matrix @scheme[a], @scheme[b], @scheme[c] und @scheme[d], wobei + @scheme[a], @scheme[b], @scheme[c] mit 0 und @scheme[d] mit 1 erweitert wird, um eine homogene Matrix zu erzeugen. +} + +@defthing[transpose-matrix4x4 (matrix4x4 -> matrix4x)]{ + @scheme[(transpose-matrix4x4 m)] erstellt die transponierte Matrix @scheme[m]^@scheme[T]. +} + +@defthing[multiply-matrix-vec4 (matrix vec4 -> vec4)]{ + @scheme[(multiply-matrix-vec4 m v)] gibt die Matrix @scheme[m]@scheme[v] zurück. Die @scheme[w]-Komponente ist nicht normalisiert. +} + +@defthing[transform-vec3 (matrix4x4 vec3 -> vec3)]{ + @scheme[(transform-vec3 m v)] erweitert @scheme[v] mit 1, multipliziert @scheme[m] mit @scheme[v] und dividiert das Ergebnis mit @scheme[w]. +} + +@defthing[multiply-matrix (matrix4x4 matrix4x4 -> matrix4x4)]{ + @scheme[(multiply-matrix a b)] gibt die Matrix @scheme[a]*@scheme[b] zurück. +} + +@defthing[create-translation-matrix (vec3 -> matrix4x4)]{ + @scheme[(create-translation-matrix v)] gibt die Translations-Matrix zurück. +} + +@defthing[create-rotation-x-matrix (number -> matrix4x4)]{ + @scheme[(create-rotation-x-matrix a)] gibt eine Rotations-Matrix zurück die um die X-Achse mit dem Winkel @scheme[a] rotiert. +} + +@defthing[create-rotation-y-matrix (number -> matrix4x4)]{ + @scheme[(create-rotation-y-matrix a)] gibt eine Rotations-Matrix zurück die um die Y-Achse mit dem Winkel @scheme[a] rotiert. +} + +@defthing[create-rotation-z-matrix (number -> matrix4x4)]{ + @scheme[(create-rotation-z-matrix a)] gibt eine Rotations-Matrix zurück die um die Z-Achse mit dem Winkel @scheme[a] rotiert. +} + +@defthing[create-lookat-matrix (vec3 vec3 vec3 -> matrix4x4)]{ + @scheme[(create-lookat-matrix pos lookat up)] gibt eine Kameramatrix. Ursprungspunkt ist @scheme[pos], die Z-Achse zeigt auf @scheme[lookat]. +} + +@defthing[create-projection-matrix (number -> matrix4x4)]{ + @scheme[(create-projection-matrix vertical-fov/2)] erzeugt eine Projektions-Matrix. @scheme[vertical-fov]/2 gibt den vertikalen Winkel der Ansicht dividiert durch 2 an. +} + +@defthing[create-viewport-matrix (natural natural -> matrix4x4)]{ + @scheme[(create-viewport-matrix width height)] gibt einen Ausschnitt an. +} + +@;------------------------------------------------------------------------------------- +@section[#:tag "3dline"]{3d-Linien} + + +@defthing[line3d contract]{ + Eine @deftech{3d-Linie} @scheme[line3d] ist ein Record, der durch den Aufruf @scheme[make-line3d] erstellt wird und eine farbige Linie zwischen zwei Punkten + im 3-dimensionalen Raum darstellt. +} + +@defthing[make-line3d (vec3 vec3 color -> line3d)]{ + @scheme[(make-line3d a b col)] erstellt eine 3D-Linie zwischen Punkt @scheme[a] und Punkt @scheme[b] mit der Farbe @scheme[col]. +} + +@defthing[line3d-a (line3d -> vec3)]{ + extrahiert den Anfangspunkt einer 3D-Linie.} + +@defthing[line3d-b (line3d -> vec3)]{ + extrahiert den Endpunkt einer 3D-Linie.} + +@defthing[line3d-color (line3d -> color)]{ + extrahiert die Farbe einer 3D-Linie.} + +@defthing[create-box (number number number color -> (list line3d))]{ + @scheme[(create-box width height depth color)] erstellt eine Box am Punkt (0,0,0) in den angebenen Ausmaßen. +} + +@defthing[transform-primitive-list ((list line3d) matrix4x4 -> (list line3d))]{ + @scheme[(transform-primitive-list scene transformationr)] wendet @scheme[transformation] auf alle Punkte der Linien in @scheme[scene] an und gibt + diese zurück. +} \ No newline at end of file diff --git a/collects/teachpack/deinprogramm/scribblings/p1.jpg b/collects/teachpack/deinprogramm/scribblings/p1.jpg new file mode 100644 index 0000000000..100685686c Binary files /dev/null and b/collects/teachpack/deinprogramm/scribblings/p1.jpg differ diff --git a/collects/teachpack/deinprogramm/scribblings/p2.jpg b/collects/teachpack/deinprogramm/scribblings/p2.jpg new file mode 100644 index 0000000000..41a10e1a61 Binary files /dev/null and b/collects/teachpack/deinprogramm/scribblings/p2.jpg differ diff --git a/collects/teachpack/deinprogramm/scribblings/p3.jpg b/collects/teachpack/deinprogramm/scribblings/p3.jpg new file mode 100644 index 0000000000..a416ba2336 Binary files /dev/null and b/collects/teachpack/deinprogramm/scribblings/p3.jpg differ diff --git a/collects/teachpack/deinprogramm/scribblings/p4.jpg b/collects/teachpack/deinprogramm/scribblings/p4.jpg new file mode 100644 index 0000000000..f6b6c2af70 Binary files /dev/null and b/collects/teachpack/deinprogramm/scribblings/p4.jpg differ diff --git a/collects/teachpack/deinprogramm/scribblings/shared.ss b/collects/teachpack/deinprogramm/scribblings/shared.ss new file mode 100644 index 0000000000..75c1632401 --- /dev/null +++ b/collects/teachpack/deinprogramm/scribblings/shared.ss @@ -0,0 +1,10 @@ +#lang scheme/base + +(require scribble/manual) + +(provide teachpack) + +(define (teachpack tp . name) + (apply title #:tag tp + `(,@name ": " ,(filepath (format "~a.ss" tp)) + ,(index (format "~a-Teachpack" tp))))) diff --git a/collects/teachpack/deinprogramm/scribblings/sound.scrbl b/collects/teachpack/deinprogramm/scribblings/sound.scrbl new file mode 100644 index 0000000000..b4bb1b3ada --- /dev/null +++ b/collects/teachpack/deinprogramm/scribblings/sound.scrbl @@ -0,0 +1,33 @@ +#lang scribble/doc + +@(require scribble/manual + "shared.ss" + scribble/struct + (for-label scheme + teachpack/deinprogramm/sound)) + +@teachpack["sound"]{Abspielen von Audio-Dateien} + +Note: This is documentation for the @tt{sound.ss} teachpack that goes +with the German textbook +@italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht der +Abstraktion}}. + +Dieses Teachpack definiert eine Prozedur zum Abspielen einer +Audio-Datei. Diese Prozedur ist je nach Plattform unterschiedlich +realisiert, und funktioniert möglicherweise nicht auf jedem +Rechner. + +@declare-exporting[teachpack/deinprogramm/sound] + +@defthing[play-sound-file (string -> unspecific)]{ +Der Aufruf +@scheme[(play-sound-file f)] spielt die Audio-Datei mit dem Namen +@scheme[f] ab.} + +@defthing[background-play-sound-file (string -> unspecific)]{ +Der Aufruf +@scheme[(background-play-sound-file f)] spielt die Audio-Datei mit dem Namen +@scheme[f] im Hintergrund ab, also ohne dass das Scheme-Programm anhält.} + + diff --git a/collects/teachpack/deinprogramm/scribblings/turtle.scrbl b/collects/teachpack/deinprogramm/scribblings/turtle.scrbl new file mode 100644 index 0000000000..a71dfab851 --- /dev/null +++ b/collects/teachpack/deinprogramm/scribblings/turtle.scrbl @@ -0,0 +1,180 @@ +#lang scribble/doc + +@(require scribble/manual + "shared.ss" + scribble/struct + (for-label scheme + teachpack/deinprogramm/image + teachpack/deinprogramm/turtle)) + +@teachpack["turtle"]{Turtle-Grafik} + +Note: This is documentation for the @tt{turtle.ss} teachpack that goes +with the German textbook +@italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht der +Abstraktion}}. + +@declare-exporting[teachpack/deinprogramm/turtle #:use-sources (teachpack/deinprogramm/turtle)] + +Turtle-Grafik ist eine Methode zum Erstellen von Computergrafiken. Das +Zeichnen wird dabei durch das Bewegen einer virtuellen Schildkröte +über den Zeichenbereich modelliert. Eine Schildkröte kann durch drei +Befehle bewegt werden: + +@itemize{ + @item{@scheme[(move n)] Bewegt die Schildkröte um @scheme[n] Pixel ohne zu zeichnen.} + @item{@scheme[(draw n)] Bewegt die Schildkröte um @scheme[n] Pixel und zeichnet dabei.} + @item{@scheme[(turn n)] Dreht die Schildkröte um n Grad im Uhrzeigersinn.} +} + +Wir stellen jetzt ein Teachpack für DrScheme vor, mit dessen Hilfe +solche Turtle-Grafiken erstellt werden können. + +@section{Tutorial} + +Unser Ziel ist es, in diesem Tutorial ein Quadrat mithilfe der +Prozeduren des Teachpacks zu zeichnen. Aus diesem Grund müssen wir +zunächst mit der Prozedur @scheme[draw] eine Linie nach rechts malen. Die +initiale Ausgansposition der Turtle ist in der Bildmitte mit Blick +nach rechts. Mit @scheme[(draw 20)] bewegen wir die Turtle dann 20 Pixel nach +rechts und zeichnen dabei. Um das resultierende Bild zu sehen ist, +müssen wir die Turtle mittels der Prozedur run laufen lassen. Die +restlichen Parameter für run sind die Höhe und die Breite des Bildes +sowie die Farbe, in der gezeichnet werden soll. Geben Sie also +folgenden Befehl in die REPL ein, um Ihre erste Turtle-Grafik zu +erstellen: + +@schemeblock[ +(run (draw 20) 100 100 "red") +] + +Sie erhalten dann eine Ausgabe wie die folgende: + +@image["p1.jpg"] + +Nun vervollständigen wir die Linie zu einem rechten Winkel: wir drehen +die Turtle um 90° nach rechts und zeichnen dann eine Line der Länge 20 +Pixel nach unten. Zum Drehen einer Turtle verwenden wir die Prozedur +@scheme[turn]. + +Da wir ein Quadrat aus zwei rechten Winkeln zusammensetzen können, +abstrahieren wir über das Zeichnen des rechten Winkels. Dazu schreiben +wir eine Prozedur @scheme[right-angle] die als Parameter eine Turtle +erhält: + +@schemeblock[ +(: right-angle (turtle -> turtle)) +(define right-angle + (lambda (t1) + (let* ((t2 ((draw 20) t1)) + (t3 ((turn -90) t2)) + (t4 ((draw 20) t3))) + t4))) +] + +Das Ergebnis sieht dann so aus: + +@image["p2.jpg"] + +Um das Quadrat komplett zu zeichnen, sollen nun zwei rechte Winkel +verwendet werden. Wir zeichnen also einen rechten Winkel, drehen uns +um 90° nach rechts, und zeichnen einen zweiten rechten Winkel. + +@schemeblock[ +(: square (turtle -> turtle)) +(define square + (lambda (t1) + (let* ((t2 (right-angle t1)) + (t3 ((turn -90) t2)) + (t4 (right-angle t3))) + t4))) +] + +So sieht das Ergebnis aus: + +@image["p3.jpg"] + +@subsection{Verbesserungen} + +An dem Beispiel ist leicht zu sehen, dass es zum Zeichnen mit Hilfe +von Turtle-Grafik oft erforderlich ist, Zwischenwerte wie @scheme[t1], +@scheme[t2] etc., an die nächste Prozedur weiterzureichen, die Werte +ansonsten aber nicht weiterverwendet werden. Beispielsweise werden in +der obigen Definition von square die Variablen @scheme[t1], ..., +@scheme[t4] nur gebraucht, um die Prozeduren @scheme[right-angle], +@scheme[(turn -90)] und @scheme[right-angle] hintereinander +auszuführen. + +Um solche Fälle einfach programmieren zu können, enthält das +Turtle-Teachpack die Prozedur @scheme[sequence]. Damit können wir eine +zu @scheme[right-angle] äquivalente Version wesentlicher einfacher +aufschreiben: + +@schemeblock[ +(define right-angle2 + (sequence (draw 20) (turn -90) (draw 20))) +] + +Ebenso wie @scheme[right-angle] können wir square leichter schreiben als: + +@schemeblock[ +(define square2 + (sequence right-angle (turn -90) right-angle)) +] + +@section{Prozeduren} + +@declare-exporting[teachpack/deinprogramm/turtle] + +@defthing[turtle contract]{ +Dies ist der Vertrag für Turtles. +} + +@defthing[set-color (color -> (turtle -> turtle))]{ Diese Prozedur ist +eine Prozedurfabrik. Sie liefert als Ergebnis eine Prozedur, die auf +eine Turtle anwendbar ist. Wendet man das Ergebnis auf eine Turtle an, +so ändert dies die Farbe mit der gezeichnet wird. + +Folgender Code + +@schemeblock[ +(define square3 + (sequence right-angle (turn -90) (set-color "blue") right-angle)) +] +liefert dieses Bild: + +@image["p4.jpg"] +} + +@defthing[turn (number -> (turtle -> turtle))]{ Diese Prozedur ist +eine Prozedurfabrik. Sie liefert als Ergebnis eine Prozedur, die auf +eine Turtle anwendbar ist. Wendet man das Ergebnis auf eine Turtle an, +so ändert sich die Blickrichtung der Turtle um die gegebene Gradzahl +gegen den Uhrzeigersinn. +} + +@defthing[draw (number -> (turtle -> turtle))]{ Diese Prozedur ist +eine Prozedurfabrik. Sie liefert als Ergebnis eine Prozedur, die auf +eine Turtle anwendbar ist. Wendet man das Ergebnis auf eine Turtle an, +so bewegt sich die Schildkröte um die gegebene Anzahl von Pixel und +zeichnet dabei eine Linie.} + +@defthing[move (number -> (turtle -> turtle))]{ Diese Prozedur ist eine +Prozedurfabrik. Sie liefert als Ergebnis eine Prozedur, die auf ein +Turtle anwendbar ist. Wendet man das Ergebnis auf eine Turtle an, so +bewegt sich die Schildkröte um die gegebene Anzahl von Pixel, zeichnet +dabei aber keine Linie.} + +@defthing[run ((turtle -> turtle) number number color -> image)]{ +Diese Prozedur wendet die übergebene Prozedur von Turtle nach Turtle +auf die initiale Schildkröte an und zeigt das daraus resultierende +Bild an. Der zweite Parameter ist die Höhe des Bilds, der dritte +Parameter die Breite des Bilds und der vierte Parameter die Farbe, mit +der gezeichnet wird. +} + +@defthing[sequence ((turtle -> turtle) ... -> (turtle -> turtle))]{ +Diese Prozedur nimmt eine beliebige Anzahl von Turtle-Veränderungen +(d.h. Prozeduren mit Vertrag @scheme[turtle -> turtle]) und erstellt +eine neue Prozedur, die die Veränderungen der Reihe nach von links +nach rechts abarbeitet.} diff --git a/collects/teachpack/deinprogramm/scribblings/world.scrbl b/collects/teachpack/deinprogramm/scribblings/world.scrbl new file mode 100644 index 0000000000..588370c9ff --- /dev/null +++ b/collects/teachpack/deinprogramm/scribblings/world.scrbl @@ -0,0 +1,82 @@ +#lang scribble/doc + +@(require scribble/manual + "shared.ss" + scribble/struct + (for-label scheme + teachpack/deinprogramm/image + teachpack/deinprogramm/world)) + +@teachpack["world"]{Animationen} + +Note: This is documentation for the @tt{world.ss} teachpack that goes +with the German textbook +@italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht der +Abstraktion}}. + +Dieses Teachpack ermöglicht, kleine Animationen und Spiele zu programmieren. +Es enthält alle Prozeduren aus dem +@seclink["image"]{image-Teachpack}. + +@declare-exporting[teachpack/deinprogramm/world #:use-sources (teachpack/deinprogramm/world)] + +@defthing[world contract]{ +Eine @deftech{Welt} (Name: @scheme[world]) ist die Repräsentation des Zustands, +der durch die Animation abgebildet wird. +} + +@defthing[mouse-event-kind contract]{ +@scheme[(one-of "enter" "leave" "motion" "left-down" "left-up" "middle-down" "middle-up" "right-down" "right-up")] + +Eine @deftech{Mausereignis-Art} (Name: @scheme[mouse-event-kind]) +bezeichnet die Art eines Maus-Ereignisses: + +@scheme["enter"] bedeutet, daß der Mauszeiger gerade +in das Fenster hinein bewegt wurde. @scheme["leave"] bedeutet, daß der +Mauszeiger gerade aus dem Fenster heraus bewegt wurde. +@scheme["motion"] bedeutet, daß der Mauszeiger innerhalb des +Fensters bewegt wurde. Die anderen Zeichenketten bedeuten, daß der +entsprechende Mausknopf gedrückt oder losgelassen wurde.} + +@defthing[big-bang (natural natural number world -> (one-of #t))]{ +Der Aufruf @scheme[(big-bang w h n w)] +erzeugt eine Leinwand mit Breite @scheme[w] und Höhe +@scheme[h], startet die Uhr, die alle @scheme[n] Sekunden +tickt, und macht @scheme[w] zur ersten Welt.} + +@defthing[on-tick-event ((world -> world) -> (one-of #t))]{ +Der Aufruf @scheme[(on-tick-event tock)] +meldet @scheme[tock] +als Prozedur an, die bei jedem Uhren-Tick aufgerufen wird, um aus +der alten Welt eine neue zu machen.} + +@defthing[on-key-event ((world string -> world) -> (one-of #t))]{ +Der Aufruf @scheme[(on-key-event change)] +meldet @scheme[change] +als Prozedur an, die bei jedem Tastendruck aufgerufen wird, um aus +der alten Welt eine neue zu machen. Dabei wird als Argument eine +Zeichenkette übergeben, welche die Taste darstellt, also +@scheme["a"] für die A-Taste etc., sowie @scheme["up"], +@scheme["down"], @scheme["left"], und @scheme["right"] +für die entsprechenden Pfeiltasten und @scheme["wheel-up"] für die +Bewegung des Mausrads nach oben und @scheme["wheel-down"] für die +Bewegung des Mausrads nach unten.} + +@defthing[on-mouse-event ((world natural natural mouse-event-kind -> world) -> (one-of #t))]{ +Der Aufruf @scheme[(on-mouse-event change)] +meldet @scheme[change] +als Prozedur an, die bei jedem Mausereignis aufgerufen wird, um aus +der alten Welt eine neue zu machen. Die @scheme[change]-Prozedur +wird als @scheme[(change w x y k)] aufgerufen. Dabei ist @scheme[w] +die alte Welt, @scheme[x] und @scheme[y] die Koordinaten des +Mauszeigers, und @scheme[k] die Art des Mausereignisses.} + +@defthing[on-redraw ((world -> image) -> (one-of #t))]{ +Der Aufruf @scheme[(world->image world->image)] +meldet die +Prozedur @scheme[world->image] an, die aus einer Welt +ein Bild macht, das auf der Leinwand dargestellt wird.} + +@defthing[end-of-time (string -> world)]{ +Diese Prozedur hält die Welt an und druckt ihr Argument in der REPL aus.} + diff --git a/collects/teachpack/deinprogramm/sound.ss b/collects/teachpack/deinprogramm/sound.ss new file mode 100644 index 0000000000..f8d55bc99c --- /dev/null +++ b/collects/teachpack/deinprogramm/sound.ss @@ -0,0 +1,13 @@ +(module sound mzscheme + (require (lib "mred.ss" "mred")) + + (define (play-sound-file file) + (play-sound file #f) + (void)) + + (define (background-play-sound-file file) + (play-sound file #t) + (void)) + + (provide play-sound-file + background-play-sound-file)) diff --git a/collects/teachpack/deinprogramm/turtle.ss b/collects/teachpack/deinprogramm/turtle.ss new file mode 100644 index 0000000000..2b3c92fc6f --- /dev/null +++ b/collects/teachpack/deinprogramm/turtle.ss @@ -0,0 +1,3 @@ +(module turtle mzscheme + (provide (all-from (lib "turtle.ss" "deinprogramm"))) + (require (lib "turtle.ss" "deinprogramm"))) diff --git a/collects/teachpack/deinprogramm/world.ss b/collects/teachpack/deinprogramm/world.ss new file mode 100644 index 0000000000..5637fc31df --- /dev/null +++ b/collects/teachpack/deinprogramm/world.ss @@ -0,0 +1,3 @@ +(module world mzscheme + (provide (all-from (lib "world.ss" "deinprogramm"))) + (require (lib "world.ss" "deinprogramm"))) \ No newline at end of file