(FILECREATED " 5-Dec-84 22:52:19" {ERIS}<LISPUSERS>PLURAL.;5
 3925   

      changes to:  (VARS PLURALCOMS)
		   (FNS ORDINALSUFFIXSTRING Ordinal)

      previous date: "28-Sep-84 10:05:51" {ERIS}<LISPUSERS>PLURAL.;3)


(* Copyright (c) 1984 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT PLURALCOMS)

(RPAQQ PLURALCOMS
 ((FNS Conjoin ORDINALSUFFIXSTRING Ordinal Plural Suffix)))
(DEFINEQ

(Conjoin

  [LAMBDA (a b)                                              (* mk: "26-MAY-84 10:38")

    (
CONCAT
 a (if
 (
U-CASEP
 (
SUBSTRING
 a -1 -1))
		  then
 (
U-CASE
 b)
		else
 b])

(ORDINALSUFFIXSTRING

  (LAMBDA (N CAP)                                            (* JonL " 5-Dec-84 22:52")

    (
SETQ
 N (IABS N))
    (if
 (
OR
 (
AND
 (
IGEQ
 N 4)
		 (
ILEQ
 N 20))
	    (
EQ
 0 (
SETQ
 N (
IREMAINDER
 N 10)))
	    (
IGEQ
 N 4))
	then
 (if
 CAP
		 then
 "TH"
	       else
 "th")
      else
 (
SELECTQ
 N
		    (1 (if
 CAP
			   then
 "ST"
			 else
 "st"))
		    (2 (if
 CAP
			   then
 "ND"
			 else
 "nd"))
		    (3 (if
 CAP
			   then
 "RD"
			 else
 "rd"))
		    (
SHOULDNT
)))))

(Ordinal

  (LAMBDA (N CAP)                                            (* JonL " 5-Dec-84 22:51")

    (
CONCAT
 N (ORDINALSUFFIXSTRING
 N CAP))))

(Plural

  [LAMBDA (word n)                                           (* mk: "28-Sep-84 10:04")

    (
COND

      [(
NOT
 (
AND
 (
FIXP
 n)
		 (
EQ
 n 1)))
	(
PROG
 (penult pl lCase)
	      [if
 (
SETQ
 pl (
GETP
 (
MKATOM
 (
SETQ
 lCase (
L-CASE
 word)))
				 (
QUOTE
 PLURAL)))
		  then
 (
RETURN
 (
MKSTRING
 (if
 (
EQP
 word lCase)
					     then
 pl
					   elseif
 (
U-CASEP
 word)
					     then
 (
U-CASE
 pl)
					   else
 (
L-CASE
 pl T]
	      (
SETQ
 penult (
SELECTQ
 (
MKATOM
 (
SUBSTRING
 lCase -2 -2))
				    ((a e i o u)
				      (
QUOTE
 v))
				    ((s c)
				      (
QUOTE
 s))
				    NIL))
	      (
RETURN
 (
SELECTQ
 (
MKATOM
 (
SUBSTRING
 lCase -1 -1))
			       (y (if
 (
EQ
 penult (
QUOTE
 v))
				      then
 (Conjoin
 word "s")
				    else
 (Conjoin
 (
SUBSTRING
 word 1 -2)
						  "ies")))
			       (h (if
 (
EQ
 penult (
QUOTE
 s))
				      then
 (Conjoin
 word "es")
				    else
 (Conjoin
 word "s")))
			       ((j s x z)
				 (Conjoin
 word "es"))
			       (Conjoin
 word "s"]
      (T (
MKSTRING
 word])

(Suffix

  [LAMBDA (a b)                                              (* mk: "24-MAY-84 19:57")

    (
PROG
 (char)
          (
RETURN
 (
SELECTQ
 (
SETQ
 char (
MKATOM
 (
SUBSTRING
 a -1 -1)))
			   [e (
SELECTQ
 (
MKATOM
 (
SUBSTRING
 b 1 1))
				       ((a e i o u)
					 (
CONCAT
 (
L-CASE
 (
SUBSTRING
 a 1 -2))
						 (
L-CASE
 b)))
				       (
CONCAT
 (
L-CASE
 a)
					       (
L-CASE
 b]
			   [y (
SELECTQ
 (
MKATOM
 (
SUBSTRING
 a -2 -2))
				       ((a e i o u)
					 (
CONCAT
 (
L-CASE
 a)
						 (
L-CASE
 b)))
				       (
SELECTQ
 (
MKATOM
 (
SUBSTRING
 b 1 1))
						((a e o u)
						  (
CONCAT
 (
L-CASE
 (
SUBSTRING
 a 1 -2))
							  "i"
							  (
L-CASE
 b)))
						(S (
CONCAT
 (
L-CASE
 (
SUBSTRING
 a 1 -2))
							   (
L-CASE
 "ies")))
						(
CONCAT
 (
L-CASE
 a)
							(
L-CASE
 b]
			   [(b d c f g l m n p r t)
			     (
OR
 (
CheckDoubling
 a b)
				 (
CONCAT
 (
L-CASE
 a)
					 (
U-CASE
 b]
			   [s (
OR
 (
CheckDoubling
 a b)
				  (
CheckSibilant
 a b)
				  (
CONCAT
 (
L-CASE
 a)
					  (
U-CASE
 b]
			   [(h x z)
			     (
OR
 (
CheckSibilant
 a b)
				 (
CONCAT
 (
L-CASE
 a)
					 (
L-CASE
 b]
			   (
CONCAT
 (
L-CASE
 a)
				   (
L-CASE
 b])
)
(PUTPROPS PLURAL COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (402 3848 (Conjoin 412 . 622) (ORDINALSUFFIXSTRING 624 . 1202) (Ordinal 1204 . 1361) (
Plural 1363 . 2541) (Suffix 2543 . 3846)))))
STOP