LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032637. :SYSTEM-TYPE :LOGICAL :VERSION 3. :TYPE "LISP" :NAME "DEUTSC" :DIRECTORY ("REL3-PUBLIC" "PUBLIC" "GRAPHICS-DEMO") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-PUBLIC\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2753213609. :AUTHOR "REL3" :LENGTH-IN-BYTES 6118. :LENGTH-IN-BLOCKS 6. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                   ;-*- Mode:Common-Lisp; Package:DEMO; Base:10 -*-;;; Print date and time in german ;;; Ancient MIT CADR hack, converted to Common-Lisp(DEFPARAMETER GERMAN-SMALL #("ein" "zwei" "drei" "vier" "fuenf" "sechs"     "sieben" "acht" "neun" "zehn" "elf" "zwoelf"     "dreizehn" "veirzehn" "fuenfzehn" "sechszehn"     "siebzehn" "achtzehn" "neunzehn"))(DEFPARAMETER GERMAN-MEDIUM #("zwanzig" "dreissig" "vierzig" "fuenfzig"      "sechsig" "siebzig" "achtzig" "neunzig"))(DEFPARAMETER GERMAN-LARGE #("tausand" "Million" "Milliard" "Billion"     "Billiard" "Trillion" "Trilliard"     "Quadrillion"))(DEFPARAMETER GERMAN-ORDINAL-SMALL #("erste" "zwitte" "dritte" "vierte"     "fuenfste" "sechste" "siebenste"     "achtste" "neunte" "zehnte" "elfte"     "zwoelfte" "dreizehnte" "veirzehnte"     "fuenfzehnte" "sechszehnte"     "siebzehnte" "achtzehnte"     "neunzehnte"))(DEFUN GERMAN-PRINT-THOUSAND (N STREAM ORDINAL-P)  (LET ((N (rem N 100.))(H (floor N 100.)))    (COND ((> H 0)   (FUNCALL STREAM ':STRING-OUT (AREF GERMAN-SMALL (1- H)))   (FUNCALL STREAM ':STRING-OUT "hundert")   (AND ORDINAL-P (ZEROP N)(FUNCALL STREAM ':TYO #\e))))    (COND ((= N 0))  ((< N 20.)   (FUNCALL STREAM ':STRING-OUT (AREF (IF ORDINAL-P GERMAN-ORDINAL-SMALL GERMAN-SMALL)      (1- N))))  (T   (COND ((PLUSP (SETQ H (rem N 10.)))  (FUNCALL STREAM ':STRING-OUT (AREF GERMAN-SMALL (1- H)))  (AND (= H 1) (FUNCALL STREAM ':TYO #\s));Handle einsundzwanzig  (FUNCALL STREAM ':STRING-OUT "und")))   (FUNCALL STREAM ':STRING-OUT (AREF GERMAN-MEDIUM (- (floor N 10.) 2)))   (AND ORDINAL-P (FUNCALL STREAM ':STRING-OUT "ste"))))))(DEFUN GERMAN-PRINT (N &OPTIONAL (STREAM *STANDARD-OUTPUT*) (EINS-P T) ORDINAL-P)  (COND ((ZEROP N) (FUNCALL STREAM ':STRING-OUT (IF ORDINAL-P "nullte" "zero")))((< N 0) (FUNCALL STREAM ':STRING-OUT "minus") (FUNCALL STREAM ':TYO #\space) (GERMAN-PRINT (- N) STREAM))(T (DO ((N N)      (P)      (FLAG)      (LIMIT (expt 10. 24.) (floor LIMIT 1000.))      (I 7 (1- I)))     ((< I 0)      (COND ((> N 0)     (AND FLAG (FUNCALL STREAM ':TYO #\space))     (GERMAN-PRINT-THOUSAND N STREAM ORDINAL-P)     (AND (= N 1) EINS-P (FUNCALL STREAM ':TYO #\s)))    ((AND ORDINAL-P FLAG)     (FUNCALL STREAM ':STRING-OUT "te"))))   (COND ((NOT (< N LIMIT))  (SETQ P (floor N LIMIT)N (rem N LIMIT))  (COND (FLAG (FUNCALL STREAM ':TYO #\space))(T (SETQ FLAG T)))  (GERMAN-PRINT P STREAM NIL)  (COND ((>= I 1) (AND (= P 1);Past 1M are feminine      (FUNCALL STREAM ':TYO #\e)) (FUNCALL STREAM ':TYO #\space))(T (SETQ FLAG NIL)))  (FUNCALL STREAM ':STRING-OUT (AREF GERMAN-LARGE I))))))));; The :FRESH-LINE and #\NEWLINE are necessary since the line height is being;; temporarily changed.(DEFPROP :GERMAN GERMAN-PRINC SI:PRINC-FUNCTION)(DEFUN GERMAN-PRINC (N STREAM)  (IF (NOT (SEND STREAM :OPERATION-HANDLED-P :FONT-MAP))      (GERMAN-PRINT (IF (BIGP N) (ABS N) (- N)) STREAM)      (LET ((OLD-FONT-MAP (FUNCALL STREAM ':FONT-MAP))    (OLD-FONT (FUNCALL STREAM ':CURRENT-FONT)))(UNWIND-PROTECT  (PROGN    (FUNCALL STREAM ':SET-FONT-MAP '(FONTS:S35GER))    (FUNCALL STREAM ':SET-CURRENT-FONT 0)    (SEND STREAM :FRESH-LINE)    (GERMAN-PRINT (IF (BIGP N) (ABS N) (- N)) STREAM)    (SEND STREAM :TYO #\NEWLINE))  (FUNCALL STREAM ':SET-FONT-MAP OLD-FONT-MAP)  (FUNCALL STREAM ':SET-CURRENT-FONT OLD-FONT))(SEND STREAM :INCREMENT-CURSORPOS 0 40.)(SEND STREAM :INCREMENT-CURSORPOS 0 -40.))));; Use (SEND TERMINAL-IO :SET-FONT-MAP ()) to undo the effect of (SETQ BASE :STICKY-GERMAN).(DEFPROP :STICKY-GERMAN STICKY-GERMAN-PRINC SI:PRINC-FUNCTION)(DEFVAR GERMAN-FONT-MAP (zlc:FILLARRAY (MAKE-ARRAY 2) '(FONTS:TR18 FONTS:S35GER)))(DEFUN STICKY-GERMAN-PRINC (N STREAM)  (COND ((NOT (SEND STREAM :OPERATION-HANDLED-P :FONT-MAP)) (GERMAN-PRINT (IF (BIGP N) (ABS N) (- N)) STREAM))(T (IF (NEQ (SEND STREAM :FONT-MAP) GERMAN-FONT-MAP)       (SEND STREAM :SET-FONT-MAP GERMAN-FONT-MAP))   (UNWIND-PROTECT     (PROGN       (SEND STREAM :SET-CURRENT-FONT 1)       (GERMAN-PRINT (IF (BIGP N) (ABS N) (- N)) STREAM))     (SEND STREAM :SET-CURRENT-FONT 0)))))(DEFPROP :ASK ASK-PRINC SI:PRINC-FUNCTION)(DEFVAR ASK-CHOICES'(("Decimal" . 10.)  ("Octal" . 8.)  ("Binary" . 2.)  ("Roman" . :ROMAN)  ("Roman Old" . :ROMAN-OLD)  ("English" . :ENGLISH)  ("German" . :GERMAN)))(DEFUN ASK-PRINC (N STREAM)  (IF (AND (GET :JAPANESE 'SI:PRINC-FUNCTION)   (NOT (RASSoc :JAPANESE ASK-CHOICES)))      (NCONC ASK-CHOICES '(("Japanese" . :JAPANESE))))  (LET ((*print-base* (OR (w:MENU-CHOOSE ASK-CHOICES) 10.)))    (PRINC (IF (BIGP N) (ABS N) (- N)) STREAM)))(DEFPARAMETER GERMAN-QUARTERS #("" "viertal " "halb " "dreiviertal "))(DEFUN GERMAN-PRINT-TIME (HOURS MINUTES &OPTIONAL (STREAM *STANDARD-OUTPUT*))  (LET ((QUARTER (floor MINUTES 15.))(MINUTES (rem MINUTES 15.))(BEFORE-P))    (IF(OR (> MINUTES 10.)    (AND (> MINUTES 5) (= (rem QUARTER 2) 1)))(SETQ QUARTER (1+ QUARTER)      BEFORE-P T))    (IF (/= QUARTER 0)(SETQ HOURS (1+ HOURS)))    (IF (/= MINUTES 0)(FORMAT STREAM "~A ~:[nach~;vor~] "(AREF GERMAN-SMALL (IF BEFORE-P       (- 14. MINUTES)       (1- MINUTES)))BEFORE-P))    (FORMAT STREAM "~A" (AREF GERMAN-QUARTERS (rem QUARTER 4)))    (IF (= (SETQ HOURS (rem HOURS 24.)) 0)(FORMAT STREAM "mitnacht")(GERMAN-PRINT HOURS STREAM NIL))    ))(DEFUN WIEVIEL-UHR (&OPTIONAL (STREAM *STANDARD-OUTPUT*))  (AND (TIME:UPDATE-TIMEBASE)       (MULTIPLE-VALUE-BIND (NIL MINUTES HOURS DAY MONTH YEAR DAY-OF-THE-WEEK)   (TIME:GET-TIME)         (FUNCALL STREAM ':STRING-OUT (TIME:DAY-OF-THE-WEEK-STRING DAY-OF-THE-WEEK ':GERMAN)) (FUNCALL STREAM ':STRING-OUT " das ") (GERMAN-PRINT DAY STREAM NIL T) (FUNCALL STREAM ':TYO #\space) (FUNCALL STREAM ':STRING-OUT (TIME:MONTH-STRING MONTH ':GERMAN)) (FUNCALL STREAM ':STRING-OUT ", ") (GERMAN-PRINT (+ YEAR 1900.) STREAM NIL) (FORMAT STREAM ";~%") (GERMAN-PRINT-TIME HOURS MINUTES))))king-array-1 0 0  workin