Merge from mike/dmda branch.

This adds the language levels, teachpacks, and documentation for the
textbook "Die Macht der Abstraktion".

svn: r14019

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")))
+

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))
+

collects/deinprogramm/DMdA-advanced/lang/reader.ss

@@ -0,0 +1,2 @@
+(module reader syntax/module-reader
+  deinprogramm/DMdA-advanced)

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")))
+
+

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))

collects/deinprogramm/DMdA-assignments/lang/reader.ss

@@ -0,0 +1,2 @@
+(module reader syntax/module-reader
+  deinprogramm/DMdA-assignments)

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")))
+

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))

collects/deinprogramm/DMdA-beginner/lang/reader.ss

@@ -0,0 +1,2 @@
+(module reader syntax/module-reader
+  deinprogramm/DMdA-beginner)

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))

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"))))
+

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))

collects/deinprogramm/DMdA-vanilla/lang/reader.ss

@@ -0,0 +1,2 @@
+(module reader syntax/module-reader
+  deinprogramm/DMdA-vanilla)

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<? (string string 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 <something else>"
+(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))))

collects/deinprogramm/DMdA/lang/reader.ss

@@ -0,0 +1,2 @@
+(module reader syntax/module-reader
+  deinprogramm/DMdA)

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)

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)))))
+

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 ())))

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))

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)))))))))))))

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 "#<empty-list>" 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)))
+

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")

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:
+
+#<record:pare 1
+              #<record:pare 2
+                            #<record:pare 3
+                                          #<record:pare 5
+                                                        #<record:pare 6
+                                                                      #<record:pare 7 #<record:pare 8 "asdjkfdshfdsjkf">>>>>>>
+
+|#
+
+(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)))))
+
+

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")

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))

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"))

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")
+)

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"))) 
+
+  

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))))))

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"))

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))
+
+  )

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 '()]

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 '()]

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 '()]

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"].

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 '()]

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[]

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")))
+

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].

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)))))

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.}
+)))

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)))

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.

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)))
+
+

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")

collects/teachpack/deinprogramm/image.ss

@@ -0,0 +1,3 @@
+(module image mzscheme
+  (require (lib "image.ss" "deinprogramm"))
+  (provide (all-from (lib "image.ss" "deinprogramm"))))

collects/teachpack/deinprogramm/line3d.ss

@@ -0,0 +1,3 @@
+(module line3d  mzscheme
+  (provide (all-from (lib "line3d.ss" "deinprogramm")))
+  (require (lib "line3d.ss" "deinprogramm")))

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"]

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.}
+

collects/teachpack/deinprogramm/scribblings/info.ss

@@ -0,0 +1,3 @@
+#lang setup/infotab
+
+(define scribblings '(("deinprogramm.scrbl" (multi-page) (library -10))))

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.
+}

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)))))

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.}
+
+

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.}

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.}
+

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))

collects/teachpack/deinprogramm/turtle.ss

@@ -0,0 +1,3 @@
+(module turtle  mzscheme
+  (provide (all-from (lib "turtle.ss" "deinprogramm")))
+  (require (lib "turtle.ss" "deinprogramm")))

collects/teachpack/deinprogramm/world.ss

@@ -0,0 +1,3 @@
+(module world mzscheme
+  (provide (all-from (lib "world.ss" "deinprogramm")))
+  (require (lib "world.ss" "deinprogramm")))