;;; -*- Mode:Lisp; Syntax:Common-Lisp; Package:TALK; VSP:0; Fonts:(CPTFONT HL12 TR12I COURIER CPTFONT HL12B) -*-

;1;; File "*PHONEME-TRANSLATOR1"*
;1;; English to Phoneme translation.*
;1;; Some of the code in this file is derived from an (apparently) public domain C program.*
;1;;*
;1;; Copyright © 1989 David Forster.  Permission is granted for non-commercial use and distribution.*
;1;;*
;1;; 5ChangeLog:**
;1;;*
;1;;*		1David Forster*	1Created.*
;1;;   28 Feb 89*	1Jamie Zawinski*	1Added changelog.  Defined *CONVERT-STRING1, which handles better monetary amounts, and is able*
;1;;*				1 to send its output to streams instead of just strings.  Renamed *RULES1 to be **RULES*1.*
;1;;*

(in-package "3TALK*")


;1;;*	1Derived from: *
;1;;*
;1;;*	2AUTOMATIC TRANSLATION OF ENGLISH TEXT TO PHONETICS*
;1;;*		2BY MEANS OF LETTER-TO-SOUND RULES*
;1;;*
;1;;*			2NRL Report 7948*
;1;;*
;1;;*		  1      2January 21st, 1976**
;1;;*		2Naval Research Laboratory, Washington, D.C.*
;1;;*
;1;;*
;1;;*	2Published by the National Technical Information Service as document 1"AD/A021 929"*.*
;1;;*
;1;;*	5The Phoneme codes:*
;1;;*
;1;;*		3IY*	3bEEt*		3IH*	3bIt*
;1;;*		3EY*	3gAte*		3EH*	3gEt*
;1;;*		3AE*	3fAt*		3AA*	3fAther*
;1;;*		3AO*	3lAWn*		3OW*	3lOne*
;1;;*		3UH*	3fUll*		3UW*	3fOOl*
;1;;*		3ER*	3mURdER*		3AX*	3About*
;1;;*		3AH*	3bUt*		3AY*	3hIde*
;1;;*		3AW*	3hOW*		3OY*	3tOY*
;1;;*	
;1;;*		3p*	3Pack*		3b*	3Back*
;1;;*		3t*	3Time*		3d*	3Dime*
;1;;*		3k*	3Coat*		3g*	3Goat*
;1;;*		3f*	3Fault*		3v*	3Vault*
;1;;*		3TH*	3eTHer*		3DH*	3eiTHer*
;1;;*		3s*	3Sue*		3z*	3Zoo*
;1;;*		3SH*	3leaSH*		3ZH*	3leiSure*
;1;;*		3HH*	3How*		3m*	3suM*
;1;;*		3n*	3suN*		3NG*	3suNG*
;1;;*		3l*	3Laugh*		3w*	3Wear*
;1;;*		3y*	3Young*		3r*	3Rate*
;1;;*		3CH*	3CHar*		3j*	3Jar*
;1;;*		3WH*	3WHere*
;1;;*
;1;;*
;1;;*	1Rules are made up of four parts:*
;1;;*	
;1;;*		1The left context.*
;1;;*		1The text to match.*
;1;;*		1The right context.*
;1;;*		1The phonemes to substitute for the matched text.*
;1;;*
;1;;*	1Rules are located in file 3ENGLISH-PHONEMES.LISP**
;1;;*
;1;;*	1Procedure:*
;1;;*
;1;;*		1Seperate each block of letters (apostrophes included)*
;1;;*		1and add a space on each side.  For each unmatched*
;1;;*		1letter in the word, look through the rules where the*
;1;;*		1text to match starts with the letter in the word.  If *
;1;;*		1the text to match is found and the right and left *
;1;;*		1context patterns also match, output the phonemes for *
;1;;*		1that rule and skip to the next unmatched letter.*
;1;;*
;1;;*	1Special Context Symbols:*
;1;;*
;1;;*		3#*	1One or more vowels*
;1;;*		3:*	1Zero or more consonants*
;1;;*		3^*	1One consonant.*
;1;;*		3.*	1One of 3B*, 3D*, 3V*, 3G*, 3J*, 3L*, 3M*, 3N*, 3R*, 3W* or 3Z* (voiced* 1consonants)*
;1;;*		1%*	1One of 3ER*, 3E*, 3ES*, 3ED*, 3ING*, 3ELY* (a suffix)*
;1;;*			1(Found in right context only)*
;1;;*		3+*	1One of 3E*, 3I* or 3Y* (a "front" vowel)*



(defconstant 4PAUSE* "3 *" "2Short silence*")
(defconstant 4SILENT* "" "2No phonemes*")


(defstruct 4(rule* (:constructor (construct-rule (left match right output)))
		 (:print-function %print-rule))
  left
  match
  right
  output)

(defun 4%print-rule *(struct stream depth)
  (declare (ignore depth))
  (format stream "3#<RULE ~S ~S ~S ~S>*"
	  (rule-left struct) (rule-match struct) (rule-right struct) (rule-output struct)))


(defvar 4*rules** (make-array 27 :element-type 'list :initial-element '()))

(defun 4clear-all-rules *()
  "2Remove all phonetic rules from the database.*"
  (fill *rules* nil))

(defmacro 4add-phonemic-rule* (left match right out)
  "2Define a phonetic rule.
  LEFT and RIGHT specify the context of this rule; they may be either:
      *   The keyword 1:ANYTHING*, meaning there are no restrictions on the text to that side;
      *   The keyword* 1:NOTHING2, meaning that this rule only applies if the beginning or end of the word is adjascent in that direction;
      *   a string, meaning that this rule only applies adjascent to that string;
          The following characters, when found in this string, are interpreted specially:
          **    3#2    Matches one or more vowels
          **    3:2    Matches zero or more consonants
          **    3^2    Matches one consonant.
          **    3.2    Matches *B1, *D1, *V1, *G1, *J1, *L1, *M1, *N1, *R1, *W2 or *Z2 (voiced consonants)
          **    1%2    Matches 3ER**, 3E*, 3ES*, 3ED*, 3ING*, 2or 3ELY* (a suffix, valid in right context only)
          **    3+2    Matches *E1, *I2 or *Y2 (a ``front'' vowel)

  MATCH is the string to test for, between the left and right rules.
  OUT is what that string maps to, if the test is successful.**"

  ;1;*
  ;1; We store the rules we make on the *RULES* array.  The rules are sorted by their first letter -*
  ;1; Those beginning with A go in slot 1, those beginning with B in slot 2, etc.  Those not beginning with letters go in slot 0.*
  ;1;*
  (let* ((first-char (char match 0))
	 (alpha-index (if (alpha-char-p first-char)
			    (- (char-code first-char) #.(1- (char-code #\A)))
			    0)))
    `(progn
       (push (construct-rule ,left ,match ,right ,out)
	     (aref *RULES* ,alpha-index))
       nil)))



(proclaim '(inline isvowel))
(defun 4isvowel* (ch)
  (find (char-upcase (the string-char ch)) "3AEIOU*" :test #'char=))

(proclaim '(inline 4isconsonant*))
(defun 4isconsonant (ch)*
  (and (alpha-char-p ch) (not (isvowel ch))))



(defun 4parse-integer-with-commas *(string &key (start 0) (end (length string)) (radix 10.) junk-allowed)
  "2  Just like* PARSE-INTEGER2, except that commas in the middle of a number are ignored - *1,234,56 2parses to the number *1234562,
  and *1,232 parses to the number *1232.  Trailing commas are ignored.*"
  (declare (values parsed-number parse-end-pos))
  (do ((i start (1+ i))
       (last-real nil)  ;1 The position of the last legal non-comma character we saw.*
       (n nil))
      ((= i end)
       (if (or n junk-allowed)
	   (values n last-real)
	   (error "3Empty string.*")))
    (let* ((c (char string i))
	   (digit (digit-char-p c radix)))
      (cond (digit (setq n (+ (* (or n 0) radix) digit)
			 last-real (1+ i)))
	    ((char= c #\,))
	    (t (if junk-allowed
		   (return (values n last-real))
		   (error "3There's junk in this string: ~S*" string)))))))



(defun 4convert-string *(string &optional (stream *standard-output*))
  "2Given a string, translate it to phonetics.
  The translated string is returned if STREAM is NIL, and is written to the given stream otherwise.*"
  (if (null stream)
      (with-output-to-string (string-stream) (convert-string-1 string string-stream))
      (convert-string-1 string (if (eq stream t) *standard-output* stream))))


(defun 4convert-string-1* (string stream)
  "2Given a string, write a new string on the stream, which is the given string translated to phonetics.*"
  (let ((dollar-flag nil))
    
    (let ((index 0)				;1 Current position in word*
	  (l (length string)))
      (do (ch)
	  ((>= index l))
	(setf ch (char string index))
	
	(cond ((member ch '(#\Space #\Tab #\Newline) :test #'char=)
	       ;1; Whitespace characters simply pass through.*
	       (write-char ch stream)
	       (incf index))
	      
	      ((char= ch #\$)
	       ;1; Dollar-sign sets a flag and is handled specially later (probably in the Digit clause).*
	       (setq dollar-flag t)
	       (incf index))
	      
	      ((or (alpha-char-p ch) (char= ch #\'))
	       ;1;*
	       ;1; Alphabetic characters (and apostrophes).*
	       ;1;*
	       (when dollar-flag
		 ;1; If dollar-flag is still set, then that means nothing else handled it.  Say it now.*
		 (convert-ascii #\$ stream)
		 (setq dollar-flag nil))
	       
	       (setf index (find-rule string index
				      (aref *rules* (if (alpha-char-p ch)
							(- (char-code ch)
							   (if (lower-case-p ch)
							       #.(1- (char-code #\a))
							       #.(1- (char-code #\A))))
							0))
				      stream)))
	      
	      ((digit-char-p ch)
	       ;1;*
	1          *;1; Digits.  This clause is big and hairy to handle both decimal numbers, and monetary amounts.*
	1          *;1;*
	       (let ((decimal-point-p nil)	;1 we set this flag to T if we saw a decimal point.*
		     (decimal-p nil))		;1 we set this flag to T if we saw digits after the decimal point.*
		 (multiple-value-bind (number pos) (parse-integer-with-commas string :start index :junk-allowed t)
		   (convert-cardinal number stream)    ;1 Say the number, and continue if the next character is a decimal point.*
		   (when (and (< pos l) (setq decimal-point-p (char= (char string pos) #\.)))
		     (incf pos))
		   (let* ((end-of-numbers (and (< pos l)
					       (digit-char-p (char string pos))
					       (or (position-if-not #'digit-char-p string :start pos)
						   l))))
		     (when dollar-flag
		       (write-string (if (= number 1) "3dAAlER *" "3dAAlAArz *") stream))
		     (cond (end-of-numbers
			    (setq decimal-p t)
			    (cond (dollar-flag
				   (let* ((cents (parse-integer string :junk-allowed t
								:start pos :end (min end-of-numbers (+ 2 pos)))))
				     (when cents
				       (setq decimal-p nil)	;1 Now this flag means "decimal cents", not "decimal dollars".*
				       (write-string "3AAnd *" stream)
				       (convert-cardinal cents stream)
				       (unless (>= (+ pos 2) end-of-numbers)
					 (setq decimal-p t)
					 (write-string "3pOYnt *" stream)
					 (spell-word string stream (+ pos 2) (1- end-of-numbers)))
				       (write-string (if (and (= cents 1) (not decimal-p))
							 "3 sEHnt *" "3 sEHnts *")
						     stream))))
				  (t
				   (write-string "3pOYnt *" stream)
				   (spell-word string stream pos (1- end-of-numbers))))
			    (setq pos end-of-numbers))
			   
			   (t (when decimal-point-p (decf pos)))))	;1 Take off the decimal point - treat it as punctuation.*
		   
		   (setq index pos)
		   (setq dollar-flag nil)
		   )))
	      
	      ((standard-char-p ch)
	       ;1;*
	       ;1; This clause handles standard characters except letters and digits.  Just write them untranslated.*
	       ;1;*
	       (when dollar-flag
		 ;1; If there was a dollar-sign not before a digit, then say it now.*
		 (convert-ascii #\$ stream) (setq dollar-flag nil))
	       (write-char ch stream)
	       (incf index))
	      
	      (t ;1;*
	         ;1; If the character is not a standard character, write it as its ASCII name.*
	         ;1;*
	         (when dollar-flag
		   ;1; If there was a dollar-sign not before a digit, then say it now.*
		   (convert-ascii #\$ stream)
		   (setq dollar-flag nil))
		 (convert-ascii ch stream)
		 (incf index))))
      
      ;1; If there was a dollar-sign at the end of the string, then say it now.  (last chance!)*
      (when dollar-flag (convert-ascii #\$ stream) (setq dollar-flag nil))))
  nil)


(defun 4find-rule* (word index rules &optional (stream *standard-output*))
  "2Look for any RULES which apply to the substring of WORD starting at INDEX*"
  (let (remainder match)
    ;1;*
    ;1; Iterate over all the rules.  Compare the RULE-MATCH (the target text) of each rule to a like-sized portion of WORD at the INDEX*
    ;1; passed in.  If the strings are the same, and the LEFT and RIGHT pattern match requirements of the rule succeed, then bug out.*
    ;1; This means that order of rules in the database is important.*
    ;1;*
    ;1; When we get a good rule, dump its translation, and return the new index into the string (in case we swallowed several characters).*
    ;1;*
    (or (dolist (rule rules)
	  (setf match (rule-match rule))		;1 Match is the string of the rule we are testing.*
	  (setf remainder (+ index (length match)))	;1 Remainder is the end-position into WORD that we are comparing to MATCH.*
	  
	  (when (and (string-equal match word :start2 index :end2 remainder)	;1 Strings are the same;*
		     (pattern-match 'left  (rule-left rule) word (1- index))	;1 Left pattern-match successful;*
		     (pattern-match 'right (rule-right rule) word remainder))	;1 Right pattern-match successful.*
	    (write-string (rule-output rule) stream)
	    (return remainder)))

	;1; Otherwise, there were no rules for this letter - this shouldn't happen if the database is complete.*
	(or (cerror "3skip it~*~**"
		    "3Error: Can't find rule for: `~c' in \"~s\"~%*"
		    (char word index) word)
	    (1+ index)))
    ))


(defun 4pattern-match* (direction pattern context index)
  "2Match PATTERN against string CONTEXT, starting at INDEX, and going in DIRECTION.*"
  (check-type direction (member LEFT RIGHT))
  (check-type pattern (or (member :ANYTHING :NOTHING) simple-string))
  (check-type context simple-string)
  
  (or (eq pattern :ANYTHING) ;1 match any context*
      (and (eq pattern :NOTHING)
	   (return-from pattern-match
	     (if (eq direction 'LEFT)
		 (< index 0)
		 (>= index (length context)))))
      (do* ((lpat (length pattern))
	    (ltxt (length context))
	    (count (if (eq direction 'left) (1- lpat) 0)
		   (if (eq direction 'left) (1- count) (1+ count)))
	    (index index)
	    pat-ch
	    txt-ch)
	   ((or (minusp count)
		;1(minusp index)*
		(>= count lpat)
		;1(>= index ltxt)*
		)
	    T)
	(setf pat-ch (char pattern count)
	      txt-ch (if (< -1 index ltxt)
			 (char context index)
			 #\Null))
	;1(format t "~&... ~a ~~ ~a (~d,~d)" pat-ch txt-ch count index)*
	(case pat-ch
	  
	  (#\#			       ;1 5One or more vowels**
	   (let ((new-index (if (eq direction 'left)
				(or (position-if-not #'isvowel context :end (1+ index) :from-end t)
				    -1)
				(or (position-if-not #'isvowel context :start index)
				    ltxt))))
	     (if (= index new-index)
		 (return nil)
		 (setf index new-index))))
	  
	  (#\:			       ;1 5Zero or more consonants**
	   (let ((new-index (if (eq direction 'left)
				(or (position-if-not
				       #'isconsonant context :end (1+ index) :from-end t)
				    -1)
				(or (position-if-not
				       #'isconsonant context :start index)
				    ltxt))))
	     (if (not (= index new-index))
		 (setf index new-index))))
	  
	  (#\^			       ;1 5One consonant**
	   (if (not (isconsonant txt-ch))
	       (return NIL))
	   (if (eq direction 'LEFT) (decf index) (incf index)))
	  
	  (#\.			       ;1 5B, D, V, G, J, L, M, N, R, W, Z   -- voiced consonants**
	   (if (not (find txt-ch "3BDVGJLMNRWZ*" :test #'char-equal))
	       (return NIL))
	   (if (eq direction 'LEFT) (decf index) (incf index)))
	  
	  (#\+			       ;1 5E, I or Y (front vowel)**
	   (if (not (find txt-ch "3EIY*" :test #'char-equal))
	       (return NIL))
	   (if (eq direction 'LEFT) (decf index) (incf index)))
	  
	  (#\%			       ;1 5ER, E, ES, ED, ING, ELY (a suffix)**
	   (if (eq direction 'left)
	       (cerror "3skip it*" "3`%' not allowed left*")
	       (or (dolist (str '("3ELY*" "3E*" "3ER*" "3ES*" "3ED*" "3ING*"))
		     (let ((l (length str)))
		       (if (string-equal context str :start1 index :end1 (+ index l))
			   (return (incf index l)))
		       ))
		   (return NIL))))
	  
	  (#\Space
	   (if (not (char= txt-ch #\Null))
	       (return NIL)))
	  
	  (t
	   ;1 check for simple text or space*
	   (if (or (alpha-char-p pat-ch)
		   (char= pat-ch #\'))
	       (if (not (char-equal pat-ch txt-ch))
		   (return NIL)
		   (if (eq direction 'LEFT) (decf index) (incf index)))
	       (return (cerror "3skip it*" "3Bad char in ~(~a~) rule: '~c'~%*" direction pat-ch)))
	   )))))


;1;   Integer to Readable ASCII Conversion Routines*

(defconstant 4CARDINALS*
  #("3zIHrOW*" "3wAHn*" "3tUW*" "3THrIY*" "3fOWr*" "3fAYv*" "3sIHks*" "3sEHvAXn*" "3EYt*" "3nAYn*" "3tEHn*"
    "3IYlEHvAXn*" "3twEHlv*" "3THERtIYn*" "3fOWrtIYn*" "3fIHftIYn*" "3sIHkstIYn*" "3sEHvEHntIYn*" "3EYtIYn*" "3nAYntIYn*"))

(defconstant 4TWENTIES* #("3twEHntIY*" "3THERtIY*" "3fAOrtIY*" "3fIHftIY*" "3sIHkstIY*" "3sEHvEHntIY*" "3EYtIY*" "3nAYntIY*"))

(defconstant 4ORDINALS*
  #("3zIHrOWEHTH*" "3fERst*" "3sEHkAHnd*" "3THERd*" "3fOWrTH*" "3fIHfTH*" "3sIHksTH*" "3sEHvEHnTH*" "3EYtTH*" "3nAYnTH*" "3tEHnTH*"
    "3IYlEHvEHnTH*" "3twEHlvTH*" "3THERtIYnTH*" "3fAOrtIYnTH*" "3fIHftIYnTH*" "3sIHkstIYnTH*" "3sEHvEHntIYnTH*" "3EYtIYnTH*"
    "3nAYntIYnTH*"))

(defconstant 4LARGE-UNITS*
	     '((1000000000 "3bIHlIYAXn*")
	       (1000000    "3mIHlIYAXn*")
	       (1000       "3THAWzAEnd*")
	       (100        "3hAHndrEHd*")))


(defun 4convert-cardinal* (value stream)
   "2Translate VALUE into a string of phonemes as a cardinal number*"
   (convert-number value stream CARDINALS)
   (write-char #\Space stream))

(defun 4convert-ordinal* (value stream)
   "2Translate VALUE into a string of phonemes as an ordinal number*"
   (convert-number value stream ORDINALS)
   (write-string (if (or (plusp (mod value 10))
			 (> 0 (mod value 100) 20))
		     "3 *"
		     "3TH *")
		 stream))


(defun 4convert-number* (value &optional (stream *standard-output*) (dinals cardinals))
   "2Translate VALUE into a string of phonemes as a cardinal or ordinal number*"
   (when (< value 0)
     (write-string "3mAYnAHs *" stream)
     (setf value (- value)))
   (dolist (unit large-units)
     (let ((quant (car unit))
	   (name  (cadr unit)))
       (when (>= value quant)	;1 Billions*
	 (convert-number (floor value quant) stream CARDINALS)
	 (write-string name stream)
	 (write-char #\Space stream)
	 (setf value (mod value quant))
	 (if (zerop value)
	     (return-from CONVERT-NUMBER)		;1 Even number*
	     (if (< value 100)	;1 as in THREE BILLION AND FIVE*
		 (write-string "3AEnd *" stream))))))
   (cond ((>= value 20)
	  (multiple-value-bind (index value) (floor (- value 20) 10)
	    (write-string (aref TWENTIES index) stream)
	    (write-char #\Space stream)
	    (when (> value 0)
	      (write-string (aref dinals value) stream)
	      (write-char #\Space stream))))
	 (t
	  (write-string (aref dinals value) stream)
	  (write-char #\Space stream))))


;1; ASCII output routines*

(defconstant 4ASCII*
	#("3nUWl*" "3stAArt AXv hEHdER*" "3stAArt AXv tEHkst*" "3EHnd AXv tEHkst*"
	  "3EHnd AXv trAEnsmIHSHAXn*"
	  "3EHnkwAYr*" "3AEk*" "3bEHl*" "3bAEkspEYs*" "3tAEb*" "3lIHnIYfIYd*"
	  "3vERtIHkAXl tAEb*" "3fAOrmfIYd*" "3kAErAYj rIYtERn*" "3SHIHft AWt*"
	  "3SHIHft IHn*" "3dIHlIYt*" "3dIHvIHs kAAntrAAl wAHn*" "3dIHvIHs kAAntrAAl tUW*"
	  "3dIHvIHs kAAntrAAl THrIY*" "3dIHvIHs kAAntrAAl fOWr*" "3nAEk*" "3sIHnk*"
	  "3EHnd tEHkst blAAk*" "3kAEnsEHl*" "3EHnd AXv mEHsIHj*" "3sUWbstIHtUWt*"
	  "3EHskEYp*" "3fAYEHld sIYpERAEtER*" "3grUWp sIYpERAEtER*" "3rIYkAOrd sIYpERAEtER*"
	  "3yUWnIHt sIYpERAEtER*" "3spEYs*" "3EHksklAEmEYSHAXn mAArk*" "3dAHbl kwOWt*"
	  "3nUWmbER sAYn*" "3dAAlER sAYn*" "3pERsEHnt*" "3AEmpERsAEnd*" "3kwOWt*"
	  "3OWpEHn pEHrEHn*" "3klOWz pEHrEHn*" "3AEstEHrIHsk*" "3plAHs*" "3kAAmmAX*"
	  "3mIHnAHs*" "3pIYrIYAAd*" "3slAESH*"
	  
	  "3zIHrOW*" "3wAHn*" "3tUW*" "3THrIY*" "3fOWr*"
	  "3fAYv*" "3sIHks*" "3sEHvAXn*" "3EYt*" "3nAYn*"
	  
	  "3kAAlAXn*" "3sEHmIHkAAlAXn*" "3lEHs DHAEn*" "3EHkwAXl sAYn*" "3grEYtER DHAEn*"
	  "3kwEHsCHAXn mAArk*" "3AEt sAYn*"
	  
	  "3EY*" "3bIY*" "3sIY*" "3dIY*" "3IY*" "3EHf*" "3jIY*"
	  "3EYtCH*" "3AY*" "3jEY*" "3kEY*" "3EHl*" "3EHm*" "3EHn*" "3AA*" "3pIY*"
	  "3kw*" "3AAr*" "3EHz*" "3tIY*" "3AHw*" "3vIY*"
	  "3dAHblyUWw*" "3EHks*" "3wAYIY*" "3zEHd*"
	  
	  "3lEHft brAEkEHt*" "3bAEkslAESH*" "3rAYt brAEkEHt*" "3kAErEHt*"
	  "3AHndERskAOr*" "3AEpAAstrAAfIH*"
	  
	  "3EY*" "3bIY*" "3sIY*" "3dIY*" "3IY*" "3EHf*" "3jIY*"
	  "3EYtCH*" "3AY*" "3jEY*" "3kEY*" "3EHl*" "3EHm*" "3EHn*" "3AA*" "3pIY*"
	  "3kw*" "3AAr*" "3EHz*" "3tIY*" "3AHw*" "3vIY*"
	  "3dAHblyUWw*" "3EHks*" "3wAYIY*" "3zEHd*"
	  
	  "3lEHft brEYs*" "3vERtIHkAXl bAAr*" "3rAYt brEYs*" "3tAYld*" "3dEHl*")
   "2Sounds of all the ASCII characters*")


(defun 4convert-ascii* (character &optional (stream *standard-output*))
  (write-string (aref ASCII (char-code character)) stream))


(defun 4spell-word* (word &optional (stream *standard-output*) (start 0) end)
  (unless end (setq end (length word)))
  (do* ((i start (1+ i)))
       ((> i end))
    (convert-ascii (char word i) stream)))