;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;; 
;;; $Header: /ct/interp/calendl.l,v 1.15 84/11/02 10:46:43 alex Exp $
;;; $Log:	/ct/interp/calendl.l,v $
;;;Revision 1.15  84/11/02  10:46:43  alex
;;;fix the bug in time_of not checking 86400.sec.
;;;
;;;Revision 1.12  84/08/28  17:28:59  alex
;;;fix the increment_day function.
;;;
;;;Revision 1.11  84/05/04  11:18:03  alex
;;;replace the ctime by time.
;;;
;;;Revision 1.10  84/04/23  17:11:36  alex
;;;remove ada_time_value .
;;;
;;;Revision 1.9  84/04/23  16:10:34  alex
;;;check in the first working version.
;;;
;;;Revision 1.8  84/02/23  20:08:52  alex
;;;Just check in, no fixes yet.
;;;
;;;Revision 1.7  84/01/04  13:43:23  alex
;;;Handle the leap year.
;;;
;;;Revision 1.6  84/01/03  16:14:11  alex
;;;Include the ct_load of the diana.
;;;
;;;Revision 1.5  83/12/22  12:51:01  alex
;;;Unknown compilation error since ada_calendar_year, comment out temporary.
;;;
;;;Revision 1.4  83/11/21  17:28:35  alex
;;;Include the "ctadadt" in the depency list and elimate the "setq"s in
;;;the top level.
;;;
;;;Revision 1.3  83/11/19  22:06:02  alex
;;;replace "time" by ctime temporary, included the complete package.
;;;
;;;Revision 1.1  83/11/18  14:10:07  alex
;;;Initial revision
;;;
;;;Revision 1.1  83/11/18  13:46:18  alex
;;;Initial revision
;;;
;;;Revision 1.1  83/11/18  13:13:41  alex
;;;Initial revision
;;;
;;;Revision 1.4  83/08/11  11:49:45  mark
;;; Made a few minor formatting changes.
;;;
;;;
;;;Revision 1.3  83/08/08  11:58:12  mark
;;; Added the Ada LRM to the list of references.
;;; 
;;;Revision 1.2  83/07/12  18:38:11  penny
;;; Changed to include header and log lines and to delete history part.
;;;
;;;Revision 1.1  83/06/22  13:39:02  penny
;;; Initial revision.
;;;

;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                              CALENDL.L                           ;;;
;;;                                                                  ;;;
;;; ALEX C. MENG                                         16-NOV-83   ;;;
;;;                                                                  ;;;
;;;                                                                  ;;;
;;; This file is part of a proprietary software project.  Source     ;;;
;;; code and documentation describing implementation details are     ;;;
;;; available on a confidential, non-disclosure basis only.  These   ;;;
;;; materials, including this file in particular, are trade secrets  ;;;
;;; of Computer * Thought Corporation.                               ;;;
;;;                                                                  ;;;
;;; This file contains the functions to implement the CALENDAR       ;;;
;;;  package in LRM sec.9.6                                          ;;;
;;;                                                                  ;;;
;;; (c) Copyright 1982 and 1983,  Computer * Thought Corporation.    ;;;
;;;     All Rights Reserved.                                         ;;;
;;;                                                                  ;;;
;;; Reference materials:                                             ;;;
;;;   Foderaro and Sklower, The FRANZ LISP Manual, September 1981.   ;;;
;;;   Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981.   ;;;
;;;   Charniak et al., 1980.  Artificial Intelligence Programming.   ;;;
;;;   Miller, 1982.  The C*T Ada Tutor: Guide to the Implementation. ;;;
;;;   AJPO, Feb 1983.  ANSI/MIL-STD-1815A  Ada Reference Manual.     ;;;
;;; The following code assumes familiarity with these materials.     ;;;
;;;                                                                  ;;;
;;;	        ASSUMES CT_LOAD AND SUITABLE FILEMAP                 ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ensure presence of needed files. 

(eval-when (compile load eval) (ct_load 'charmac)) ;CT char set extensions.

(eval-when (compile load eval) (ct_load 'aip))	  ;AIP macros pkg. 

(eval-when (compile load eval) (ct_load 'compat)) ;Franz/LM compat pkg.

(eval-when (compile load eval) (ct_load 'stdenv))

(eval-when (compile load eval) (ct_load 'bifmacs))

(eval-when (compile load eval) (ct_load 'ctadadt))

(eval-when (compile load eval) (ct_load 'diana)) ; diana structure

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler Declarations and Global Variables -- 

#+franz (declare (macros t))
(declare (ct_includef 'intrpdcl))

(declare (special *time_unit*
		  *second*
		  *millisec*
		  *microsec*
		  *ada_first_year*
		  *ada_last_year*
		  *activation*
		  ))

(defun cal_init ()
  (setq *second* 0
	*millisec* (getpointpos (expt 10.0 -3))
	*microsec* (getpointpos (expt 10.0 -6))
	*time_unit* *second*
	*ada_first_year* 1901
	*ada_last_year* 2099
	))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Externally Call-able Functions/Macros -- 

;;; None presently.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal Use Only Functions/Macros -- 

;;;
;;; lisp function spec. for the package calendar
;;;

(defun initialize_calendar ()
  (progn
    (cal_init)
    (with_package calendar
		  
     (is_standard_function clock ada_calendar_clock () time)
		  
     (is_standard_function year ada_calendar_year ((in date time)) year_number)
		  
     (is_standard_function month ada_calendar_month ((in date time)) month_number)
		  
     (is_standard_function day ada_calendar_day ((in date time)) day_number)
     
     (is_standard_function seconds ada_calendar_seconds ((in date time))
			                           day_duration)
		  
     (is_standard_procedure split ada_calendar_split ((in date time)
						      (out year year_number)
						      (out month month_number)
						      (out day day_number)
						      (out seconds day_duration)))
		  
     (is_standard_function time_of ada_calendar_time_of ((in year year_number)
							 (in month month_number)
							 (in day day_number)
							 (in seconds day_duration))
					time)
		  
     (is_builtin_operator + |ada_calendar_left_time_plus|
			  ((in left time) (in right duration)) time)
		  
     (is_builtin_operator + |ada_calendar_right_time_plus|
			  ((in left duration) (in right time)) time)
     
     (is_builtin_operator - |ada_calendar_left_time_minus|
			  ((in left time) (in right duration)) time)
		  
     (is_builtin_operator - |ada_calendar_right_time_minus|
			  ((in left time) (in right time)) duration)
		  
     (is_builtin_operator < |ada_calendar_less_than|
			  ((in left time) (in right time)) boolean)
		  
     (is_builtin_operator <= |ada_calendar_less_than_or_equal|
			  ((in left time) (in right time)) boolean)
		  
     (is_builtin_operator > |ada_calendar_greater_than|
			  ((in left time) (in right time)) boolean)
		  
     (is_builtin_operator >= |ada_calendar_greater_than_or_equal|
			  ((in left time) (in right time)) boolean)
		  
     )))

;;;
;;; ada_calendar_clock
;;;
(defun ada_calendar_clock (ar)
  (with_ada_parameters ()
   (let ((ltime (get_current_time)))
     (list (first ltime)
	   (second ltime)
	   (third ltime)
	   (fourth ltime))
     )))

#+franz
(defun get_current_time ()
    (let* ((ltime (status localtime))
	   (seconds (calculate_seconds (first ltime)
				      (second ltime)
				      (third ltime)))
	   (day (fourth ltime))
	   (month (fifth ltime))
	   (year (plus 1900 (sixth ltime))))
	  (list year month day seconds)))

#+lispm
(defun get_current_time ()
  (multiple-value-bind (seconds minute hour day month year foo bar)
      (time:get-time)
    (list (plus 1900 year)
	  month
	  day
	  (calculate_seconds (// (float (time:microsecond-time))
				 (expt 10.0 6))
			     minute
			     hour))
    ))

(defun calculate_seconds (second minute hour)
    (plus second (times 60 minute) (times 3600 hour)))

;;;
;;; ada_calendar_year
;;;
(defun ada_calendar_year (ar)
    (with_ada_parameters ((date date)) 
	(ct_send (cdr (first (ada_record_value%record date)))
		 'current_value)))
    
;;;
;;; ada_calendar_month
;;;
(defun ada_calendar_month (ar)
    (with_ada_parameters ((date date))
	(ct_send (cdr (second (ada_record_value%record date)))
		 'current_value)))

;;;
;;; ada_calendar_day
;;;
(defun ada_calendar_day (ar)
    (with_ada_parameters ((date date))
	(ct_send (cdr (third (ada_record_value%record date)))
		 'current_value)))

;;;
;;; ada_calendar_seconds
;;;
(defun ada_calendar_seconds (ar)
    (with_ada_parameters ((date date))
	(ct_send (cdr (fourth (ada_record_value%record date)))
		 'current_value)))

;;;
;;; ada_calendar_split
;;;
(defun ada_calendar_split (ar)
    (with_ada_parameters ((date date) (year year) (month month) (day day)
			  (seconds seconds))
     (let ((time (ada_record_value%record date)))
	(setq year (ct_send (cdr (first time))
		 'current_value)
	      month (ct_send (cdr (second time))
		 'current_value)
	      day  (ct_send (cdr (third time))
		 'current_value)
	      seconds (ct_send (cdr (fourth time))
		 'current_value)))
     ))

;;;
;;; ada_calendar_time_of
;;;
(defun ada_calendar_time_of (ar)
    (with_ada_parameters ((year year) (month month) (day day)
			  (seconds seconds))
     (cond ((= (fpv_to_real_conversion seconds) 86400.0)
	    (setq seconds
		  (real_to_fpv_conversion 0
					  (fixed_pt_value%small_power seconds)
					  (fixed_pt_value%pointpos seconds))
		  day (add1 day))))
     ;note: day has been add one more
     (cond ((or (and (= day 29) (= month 2) (is_leap_year year))
		(and (= day 30) (= month 2) (not (is_leap_year year))))
	    (setq month 3 day 1))
	   ((or (and (= day 31) (member month '(4 6 9 11)))
		(and (= day 32) (member month '(1 3 5 7 8 10 12))))
	    (setq month (add1 month) day 1)))
     (cond ((= month 13)
	    (setq month 1 year (add1 year))))
	(list year month day seconds)))

;;;
;;; arithmetic operators
;;;
(defun |ada_calendar_left_time_plus| (ar)
  (with_ada_parameters ((time left) (duration right))
   (let* ((date (ada_record_value%record time))
	  (year (ct_send (cdr (first date))
			 'current_value))
	  (month (ct_send (cdr (second date))
			  'current_value))
	  (day  (ct_send (cdr (third date))
			 'current_value))
	  (sec (ct_send (cdr (fourth date))
			    'current_value))
	  )
     (ada_time_plus year
		    month
		    day
		    (fpv_to_real_conversion sec)
		    (fpv_to_real_conversion duration))
     )))

(defun ada_time_plus (year month day sec inc)
  (let* ((miu (plus sec inc))
	 (diff (difference miu 86400.0)))
    (cond ((lessp diff 0)
	   (list year month day miu))
	  ((eq diff 0)
	   (increment_day year month day 0))
	  (t (increment_day year month day diff)))))
    
(defun is_leap_year (yr)
    (ct_if (or (and (eq (remainder yr 4) 0)
		    (neq (remainder yr 100) 0))
	       (eq (remainder yr 400) 0))
	t
	nil))

(defun is_small_month (mon)
  (member mon '(4 6 9 11)))

(defun increment_day (year month day sec)
  (ct_selectq day
	      (28 (ct_if (and (is_leap_year year)
			      (eq month 2))
			 (list year 3 1 sec)
			 (list year month 29 sec)))
	      (29 (ct_if (and (is_leap_year year)
			      (eq month 2))
			 (list year 3 1 sec)
			 (list year 3 29 sec)))
	      (30 (ct_if (is_small_month month)
			 (list year (add1 month) 1 sec)
			 (list year month 31 sec)))
	      (31 (ct_if (eq month 12)
			 (ct_if (> (add1 year) *ada_last_year*)
				(ada_raise '|time_error|
					   "Ada expired")
				(list (add1 year) 1 1 sec))
			 (list year (add1 month) 1 sec)))
	      (otherwise (list year month (add1 day) sec))
	      ))

(defun |ada_calendar_right_time_plus| (ar)
  (with_ada_parameters ((duration left) (time right))
   (let* ((date (ada_record_value%record time))
	  (year (ct_send (cdr (first date))
			 'current_value))
	  (month (ct_send (cdr (second date))
			  'current_value))
	  (day  (ct_send (cdr (third date))
			 'current_value))
	  (sec (ct_send (cdr (fourth date))
			    'current_value))
	  )
     (ada_time_plus year
		    month
		    day
		    (fpv_to_real_conversion sec)
		    (fpv_to_real_conversion duration))
     )))
        

(defun |ada_calendar_left_time_minus| (ar)
  (with_ada_parameters ((time left) (duration right))
   (let* ((date (ada_record_value%record time))
	  (year (ct_send (cdr (first date))
			 'current_value))
	  (month (ct_send (cdr (second date))
			  'current_value))
	  (day  (ct_send (cdr (third date))
			 'current_value))
	  (sec (ct_send (cdr (fourth date))
			    'current_value))
	  )
     (ada_time_minus year
		     month
		     day
		     (fpv_to_real_conversion sec)
		     (fpv_to_real_conversion duration))
     )))


(defun ada_time_minus (year month day sec dec)
  (let ((diff (- sec dec)))
    (cond ((> diff 0)
	   (list year month day diff))
	  (t (decrement_day year month day (- (plus 86400.0 sec) dec)))
	  )))

(defun decrement_day (year month day sec)
  (ct_selectq day
	      (1 (ct_selectq month
			     (1 (list (sub1 year) 12 31 sec))
			     (3 (ct_if (is_leap_year (sub1 year))
				       (list (sub1 year) 2 29 sec)
				       (list (sub1 year) 2 28 sec)))
			     (otherwise
			       (list year
				     (sub1 month)
				     (ct_if (is_small_month (sub1 month))
					    30
					    31)))))
	      (otherwise (list year month (sub1 day) sec))
	      ))
						 
(defun |ada_calendar_right_time_minus| (ar)
  (with_ada_parameters ((ltime left) (rtime right))
    (let* ((ldate (ada_record_value%record ltime))
	   (lyear (ct_send (cdr (first ldate))
			   'current_value))
	   (lmonth (ct_send (cdr (second ldate))
			    'current_value))
	   (lday  (ct_send (cdr (third ldate))
			   'current_value))
	   (lsec (ct_send (cdr (fourth ldate))
			  'current_value))
	   (rdate (ada_record_value%record rtime))
	   (ryear (ct_send (cdr (first rdate))
			   'current_value))
	   (rmonth (ct_send (cdr (second rdate))
			    'current_value))
	   (rday  (ct_send (cdr (third rdate))
			   'current_value))
	   (rsec (ct_send (cdr (fourth rdate))
			  'current_value))
	   )
     (ada_date_minus lyear
		     lmonth
		     lday
		     (fpv_to_real_conversion lsec)
		     ryear
		     rmonth
		     rday
		     (fpv_to_real_conversion rsec)
		     ))))

(defun ada_date_minus (lyear lmonth lday lsec ryear rmonth rday rsec)
  (let ((sec_diff (- lsec rsec))
	(day_diff (- lday rday))
	(month_diff (- lmonth rmonth))
	(year_diff (- lyear ryear))
	(ans nil))
  (ct_selectq day_diff
	     (0  sec_diff)
	     (1 (ct_if ( > (setq ans
				 (+ (- 86400.0 rsec) lsec))
			86400.0)
		       (ada_raise '|time_error|
				  "the diff of two times exceed 86400.0")
		       ans))
	     (-1 (ct_if ( > (setq ans
				 (+ (- 86400.0 lsec) rsec))
			86400.0)
		       (ada_raise '|time_error|
				  "the diff of two times exceed -86400.0")
		       (minus ans)))
	     ((29 30) (ct_if (or (>= month_diff 1) (< month_diff -1))
			(ada_raise '|time_error|
				  "the diff of two times exceed one day")
			(minus (+ (- 86400.0 lsec) rsec))))
	     ((-29 -30) (ct_if (or (> month_diff 1) (<= month_diff -1))
			(ada_raise '|time_error|
				  "the diff of two times exceed one day")
			(+ (- 86400.0 rsec) lsec)))
	     (28 (ct_if (and (is_leap_year lyear)
			     (eq lmonth 2)
			     (eq rmonth 3))
			(minus (+ (- 86400.0 lsec) rsec))
			(ada_raise '|time_error|
				  "the diff of two times exceed one day")))
	     (-28 (ct_if (and (is_leap_year ryear)
			      (eq lmonth 3)
			      (eq rmonth 2))
			(+ (- 86400.0 rsec) lsec)
			(ada_raise '|time_error|
				  "the diff of two times exceed one day")))
	     (27 (ct_if (and (eq lmonth 2)
			     (eq rmonth 3))
			(minus (+ (- 86400.0 lsec) rsec))
			(ada_raise '|time_error|
				  "the diff of two times exceed one day")))
	     (-27 (ct_if (and (eq lmonth 3)
			      (eq rmonth 2))
			(+ (- 86400.0 rsec) lsec)
			(ada_raise '|time_error|
				  "the diff of two times exceed one day")))
	     (otherwise (ada_raise '|time_error|
				  "the diff of two times exceed one day")))
  ))

;;;
;;; relational operators 
;;;
(defun |ada_calendar_less_than| (ar)
  (with_ada_parameters ((ltime left) (rtime right))
   (let* ((ldate (ada_record_value%record ltime))
	   (lyear (ct_send (cdr (first ldate))
			   'current_value))
	   (lmonth (ct_send (cdr (second ldate))
			    'current_value))
	   (lday  (ct_send (cdr (third ldate))
			   'current_value))
	   (lsec (ct_send (cdr (fourth ldate))
			  'current_value))
	   (rdate (ada_record_value%record rtime))
	   (ryear (ct_send (cdr (first rdate))
			   'current_value))
	   (rmonth (ct_send (cdr (second rdate))
			    'current_value))
	   (rday  (ct_send (cdr (third rdate))
			   'current_value))
	   (rsec (ct_send (cdr (fourth rdate))
			  'current_value))
	   (ans (compare_time lyear
			      lmonth
			      lday
			      (fpv_to_real_conversion lsec)
			      ryear
			      rmonth
			      rday
			      (fpv_to_real_conversion rsec)
			      ))
	   (str (ct_if (eq ans 1) "true" "false"))
	   )
     (get-enum str *activation*))
     ))

(defun |ada_calendar_less_than_or_equal| (ar)
  (with_ada_parameters ((ltime left) (rtime right))
   (let* ((ldate (ada_record_value%record ltime))
	   (lyear (ct_send (cdr (first ldate))
			   'current_value))
	   (lmonth (ct_send (cdr (second ldate))
			    'current_value))
	   (lday  (ct_send (cdr (third ldate))
			   'current_value))
	   (lsec (ct_send (cdr (fourth ldate))
			  'current_value))
	   (rdate (ada_record_value%record rtime))
	   (ryear (ct_send (cdr (first rdate))
			   'current_value))
	   (rmonth (ct_send (cdr (second rdate))
			    'current_value))
	   (rday  (ct_send (cdr (third rdate))
			   'current_value))
	   (rsec (ct_send (cdr (fourth rdate))
			  'current_value))
	   (ans (compare_time lyear
			      lmonth
			      lday
			      (fpv_to_real_conversion lsec)
			      ryear
			      rmonth
			      rday
			      (fpv_to_real_conversion rsec)
			      ))
	   (str (ct_if (or (eq ans 1) (eq ans 0)) "true" "false"))
	   )
     (get-enum str *activation*))
   ))


(defun |ada_calendar_greater_than| (ar)
  (with_ada_parameters ((ltime left) (rtime right))
   (let* ((ldate (ada_record_value%record ltime))
	   (lyear (ct_send (cdr (first ldate))
			   'current_value))
	   (lmonth (ct_send (cdr (second ldate))
			    'current_value))
	   (lday  (ct_send (cdr (third ldate))
			   'current_value))
	   (lsec (ct_send (cdr (fourth ldate))
			  'current_value))
	   (rdate (ada_record_value%record rtime))
	   (ryear (ct_send (cdr (first rdate))
			   'current_value))
	   (rmonth (ct_send (cdr (second rdate))
			    'current_value))
	   (rday  (ct_send (cdr (third rdate))
			   'current_value))
	   (rsec (ct_send (cdr (fourth rdate))
			  'current_value))
	   (ans (compare_time lyear
			      lmonth
			      lday
			      (fpv_to_real_conversion lsec)
			      ryear
			      rmonth
			      rday
			      (fpv_to_real_conversion rsec)
			      ))
	   (str (ct_if (eq ans 2) "true" "false"))
	   )
     (get-enum str *activation*)
     )))


(defun |ada_calendar_greater_than_or_equal| (ar)
  (with_ada_parameters ((ltime left) (rtime right))
   (let* ((ldate (ada_record_value%record ltime))
	   (lyear (ct_send (cdr (first ldate))
			   'current_value))
	   (lmonth (ct_send (cdr (second ldate))
			    'current_value))
	   (lday  (ct_send (cdr (third ldate))
			   'current_value))
	   (lsec (ct_send (cdr (fourth ldate))
			  'current_value))
	   (rdate (ada_record_value%record rtime))
	   (ryear (ct_send (cdr (first rdate))
			   'current_value))
	   (rmonth (ct_send (cdr (second rdate))
			    'current_value))
	   (rday  (ct_send (cdr (third rdate))
			   'current_value))
	   (rsec (ct_send (cdr (fourth rdate))
			  'current_value))
	   (ans (compare_time lyear
			      lmonth
			      lday
			      (fpv_to_real_conversion lsec)
			      ryear
			      rmonth
			      rday
			      (fpv_to_real_conversion rsec)
			      ))
	   (str (ct_if (or (eq ans 2) (eq ans 0)) "true" "false"))
	   )
     (get-enum str *activation*)
     )))

;;;
;;; this function will return 1 if time1 < time2
;;;                           0 if time1 = time2
;;;                           2 if time1 > time2
;;;
(defun compare_time (year1 month1 day1 seconds1 year2 month2 day2 seconds2)
  (let* ((ydel (- year1 year2))
	 (mdel (- month1 month2))
	 (ddel (- day1 day2))
	 (sdel (- seconds1 seconds2)))
     (cond ((lessp ydel 0) 1)
	   ((greaterp ydel 0) 2)
	   (t
	    (cond ((lessp mdel 0) 1)
		  ((greaterp mdel 0) 2)
		  (t
		   (cond ((lessp ddel 0) 1)
			 ((greaterp ddel 0) 2)
			 (t
			  (cond ((lessp sdel 0) 1)
				((greaterp sdel 0) 2)
				(t 0))
			  ))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;