PDP-10.its/src/mprog2/parsed.udl016

<PACKAGE "PARSE-DATE">

<ENTRY PARSE-DATE PARSE-NUM SYM=? MONTH-SIZE DAYS MONTHS>

<USE "ITIME">

"*************************** DATE HACKING ***************************"

"Parse all sorts of hairy date specs:
	Used in :REMIND and in ACK. ON FAILURE."

<DEFINE PARSE-DATE (HAIRY "OPTIONAL" (FUTURE? T)
		    "AUX" (YMD <LTIME>) (DV <1 .YMD>) (DT <2 .YMD>)
		    (YY <>) (MM <>) (DD <>) (HRS <>) (MIN <>) (SEC <>)
		    X P TERM) 
   #DECL ((HAIRY) VECTOR (VALUE) <OR FALSE FIX>
	  (YMD) <LIST [2 LIST]> (DV DT) <LIST [3 FIX]> (P) ANY
	  (YY MM DD HRS MIN SEC) <OR STRING FIX FALSE>
	  (FUTURE?) <OR ATOM FALSE>)
   <COND (<EMPTY? .HAIRY> <>)
	 (ELSE
   <SET P <PARSE-NUM <1 .HAIRY>>>
   <COND (<AND <TYPE? .P STRING> <SET P <SYM=? .P ,DAYS>>>
	  <SET DD <IDAY>>
	  <COND (<1? .P>)
		(<==? .P 2> <SET P -1>)
		(<==? .P 3> <SET P 0>)
		(ELSE
		 <SET P <- .P 4>>
		 <SET P
		      <COND (.FUTURE?
			     <COND (<L=? .P .DD> <- <+ .P 7> .DD>)
				   (ELSE <- .P .DD>)>)
			    (<=? .DD .P> 0)
			    (<G? .P .DD> <- .P <+ .DD 7>>)
			    (ELSE <- .P .DD>)>>)>
	  <SET HAIRY
	       <COND (<1? <LENGTH .HAIRY>> <REST .HAIRY>)
		     (ELSE <REST .HAIRY 2>)>>
	  <PUT .DV 3 <SET DD <+ <3 .DV> .P>>>)
	 (ELSE
	  <REPEAT ()
		  <COND (<OR <EMPTY? .HAIRY>
			     <==? <2 .HAIRY> !\:>>
			 <RETURN>)>
		  <SET X <1 .HAIRY>>
		  <SET TERM <2 .HAIRY>>
		  <COND (<AND <TYPE? <SET P <PARSE-NUM .X>> FIX>
			      <COND (<AND <NOT <LENGTH? .HAIRY 3>>
					  <SYM=? <3 .HAIRY>
						 '["AM" "PM"
						   "NOON" "MIDNIGHT"]>>
				     <RETURN>)
				    (<L? .P 0> <>)
				    (<G? .P 31>
				     <AND <NOT .YY>
					  <PUT .DV 1 <SET YY <MOD .P 100>>>>)
				    (<G? .P 12>
				     <AND <NOT .DD> <PUT .DV 3 <SET DD .P>>>)
				    (<1? <LENGTH .HAIRY>>
				     <COND (<NOT .DD> <PUT .DV 3 <SET DD .P>>)
					   (<NOT .MM>
					    <PUT .DV 2 <SET MM .P>>)>)
				    (<NOT .MM> <PUT .DV 2 <SET MM .P>>)
				    (ELSE
				     <AND <NOT .DD>
					  <PUT .DV 3 <SET DD .P>>>)>>
			 <COND (<NOT <MEMQ .TERM ".-/">>
				<SET HAIRY <REST .HAIRY 2>>
				<RETURN>)>)
			(<AND <TYPE? .P STRING> <SET P <SYM=? .P ,MONTHS>>>
			 <COND (<NOT .MM> <PUT .DV 2 .P>)
			       (ELSE
				<PUT .DV 3 <SET DD .MM>>
				<PUT .DV 2 .P>)>
			 <SET MM .P>)
			(ELSE <RETURN>)>
		  <SET HAIRY <REST .HAIRY 2>>>)>
   <PUT .DT 1 <COND (.FUTURE? 6) (ELSE 0)>>
   <PUT .DT 2 0>
   <PUT .DT 3 0>
   <REPEAT ()
	   <COND (<EMPTY? .HAIRY> <RETURN>)>
	   <SET X <1 .HAIRY>>
	   <SET TERM <2 .HAIRY>>
	   <COND (<TYPE? <SET P <PARSE-NUM .X>> FIX>
		  <COND (<L? .P 0>)
			(<AND <G? .P 60> <NOT .HRS> <NOT .MIN>>
			 <PUT .DT 1 <SET HRS </ .P 100>>>
			 <PUT .DT 2 <SET MIN <MOD .P 100>>>)
			(<NOT .HRS> <PUT .DT 1 <SET HRS .P>>)
			(<NOT .MIN> <PUT .DT 2 <SET MIN .P>>)
			(<NOT .SEC> <PUT .DT 3 <SET SEC .P>>)
			(ELSE <RETURN>)>)
		 (ELSE <RETURN>)>
	   <SET HAIRY <REST .HAIRY 2>>
	   <COND (<N==? .TERM !\:> <RETURN>)>>
   <COND (<AND <NOT <EMPTY? .HAIRY>>
	       <TYPE? <SET P <1 .HAIRY>> STRING>
	       <SET P <SYM=? .P '["NOON" "MIDNIGHT"]>>>
	  <SET HAIRY <REST .HAIRY 2>>
	  <COND (<1? .P>
		 <PUT .DT 1 12>
		 <PUT .DT 2 0>
		 <PUT .DT 3 0>)
		(ELSE
		 <PUT .DT 1 11>
		 <PUT .DT 2 59>
		 <PUT .DT 3 59>)>)>
   <COND (<AND <NOT <EMPTY? .HAIRY>>
	       <TYPE? <SET P <1 .HAIRY>> STRING>
	       <SET P <SYM=? .P '["AM" "PM"]>>
	       <NOT <1? .P>>>
	  <SET HAIRY <REST .HAIRY 2>>
	  <PUT .DT 1 <SET HRS <+ <1 .DT> 12>>>)>
   <COND (<EMPTY? .HAIRY>
	  <BTIME <1 .DV> <2 .DV> <3 .DV>
		 <1 .DT> <2 .DT> <3 .DT>>)>)>>

"Parse a number from a string and return it or the string if can't"

<DEFINE PARSE-NUM (ST "AUX" (N 0))
	#DECL ((ST) STRING (N) FIX (VALUE) <OR FIX STRING>)
	<COND (<MAPF <>
		     <FUNCTION (C)
		         #DECL ((C) <PRIMTYPE WORD>)
			 <COND (<AND <G=? <SET C <ASCII .C>> *60*>
				     <L=? .C *72*>>
				<SET N <+ <* .N 10> .C -48>>)
			       (ELSE <MAPLEAVE <>>)>>
		     .ST>
	       .N)
	      (ELSE .ST)>>

<DEFINE SYM=? (STR MON "AUX" L) 
	#DECL ((STR) STRING (MON) <VECTOR [REST STRING]>
	       (L) FIX (VALUE) <OR FALSE FIX>)
	<REPEAT ()
		<COND (<EMPTY? .MON> <RETURN <>>)
		      (<OR <G=? <SET L <COMPS .STR <1 .MON>>> 3>
			   <==? .L <LENGTH <1 .MON>>>>
		       <RETURN <+ 1 <- <LENGTH <TOP .MON>> <LENGTH .MON>>>>)
		      (ELSE <SET MON <REST .MON>>)>>>

<SETG MONTH-SIZE '![31 29 31 30 31 30 31 31 30 31 30 31!]>

<SETG DAYS '["TOMORROW" "YESTERDAY" "TODAY" "SUNDAY" "MONDAY" "TUESDAY"
	     "WEDNESDAY" "THURSDAY" "FRIDAY" "SATURDAY"]>

<SETG MONTHS
      '["JANUARY"
	"FEBRUARY"
	"MARCH"
	"APRIL"
	"MAY"
	"JUNE"
	"JULY"
	"AUGUST"
	"SEPTEMBER"
	"OCTOBER"
	"NOVEMBER"
	"DECEMBER"]>

<GDECL (MONTH-SIZE) <UVECTOR [REST FIX]>
       (DAYS MONTHS) <VECTOR [REST STRING]>>

"Take two strings and return number of characters they have in common."

<DEFINE COMPS (S1 S2 "AUX" (N 0)) 
	#DECL ((S1 S2) STRING (N VALUE) FIX)
	<MAPF <>
	      <FUNCTION (C1 C2 "AUX" (A1 <ASCII .C1>) (A2 <ASCII .C2>)) 
		      #DECL ((C1 C2) CHARACTER (A1 A2) FIX)
		      <COND (<==? <COND (<AND <G? .A1 96> <L? .A1 123>>
					 <- .A1 32>)
					(ELSE .A1)>
				  <COND (<AND <G? .A2 96> <L? .A2 123>>
					 <- .A2 32>)
					(ELSE .A2)>>
			     <SET N <+ .N 1>>)
			    (ELSE <MAPLEAVE>)>>
	      .S1
	      .S2>
	.N>

<ENDPACKAGE>