;;;  schedule.el, ver.0.2, 8/20/1992 modified by tanaka

;; Copyright (C) 1990, 1991, 1992 Fujitsu Laboratories LTD.
;; Copyright (C) 1990, 1991, 1992 Hiroshi TANAKA
;;
;;; schedule.el: schedule management tool for Nemacs

;; This file is part of GNU Emacs.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.

;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.

;; Modified By::
;;   Makihiko Sato <maki@strad.se.fujitsu.co.jp>
;;     (marked with ";; --maki")
;;   SEKINE, Tatsuo <tsekine@isoternet.org>
;;     (marked with ";; --tsekine")
;;
;; Version::
;;   $Id: schedule.el,v 1.1.1.1 2003/01/17 06:12:28 take Exp $
;;
;; Credit and Thanks::
;;   Jun Morimoto <morimoto@marib.imagica.co.jp> for ver 0.2.1.6
;;
;; Comment::
;;   This program was designed for Nemacs(emacs-18.x base) originally,
;;   and is partially modified for Mule-2.x(emacs-19.x base).

(provide 'schedule)
(require 'calendar)			;; --tsekine

(defun day-of-week (m d y)
  (calendar-day-of-week (list m d y)))	;; --tsekine
;;
;; Global Variables
;;
(defvar schedule-dir "~/Calendar"
  "Default \"Schedule\" directory")

(defvar schedule-yank-variable nil
  "Schedule Yank variable.")

(defvar schedule-temporary-buffer "*Schedule Work Buffer*"
  "Working buffer name for Schedule tool.")

(defvar schedule-week-name-list
;  '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat")
  '("日" "月" "火" "水" "木" "金" "土")
  "Day of the week.")

(defvar schedule-system-holiday-assoc
  '(((1 1)	nil	nil	t)              ;;"元旦"
;    ((1 15)	nil	nil	t)              ;;"成人の日"
    ((1 10)	nil	2000	t)              ;;"成人の日"
    ((2 11)	nil	nil	t)              ;;"建国記念日"
    ((3 21)	nil	1994	t)	;; 3/20 or 21 "春分の日"
    ((3 20)	nil	2000	t)	;; 3/20 or 21 "春分の日"
    ((4 29)	nil	nil	t)              ;;"みどりの日"
    ((5 3)	nil	nil	t)              ;;"憲法記念日" 
    ((5 4)	nil	nil	t)              ;;"国民の祝日"
    ((5 5)	nil	nil	t)              ;;"子供の日"
    ((9 15)	nil	nil	t)              ;;"敬老の日"
    ((9 23)	nil	nil	t)		;;"秋分の日"
;    ((10 10)	nil	nil	t)              ;;"体育の日"
    ((10 9)	nil	2000	t)              ;;"体育の日"
    ((11 3)	nil	nil	t)              ;;"文化の日"
    ((11 23)	nil	nil	t)              ;;"勤労感謝の日"
    ((12 23)	nil	nil	t))             ;;"天皇誕生日"
  "System holiday association list. Each element is
     ((MONTH DAY) \"HOLIDAY_NAME\" YEAR NON_WORKDAY_P).")

(defvar schedule-user-holiday-assoc 
  '(
    ((1 24)	"誕生日 (1967)"	nil	nil)  
    ((7 7)	"悠希 誕生日 (1997)"	nil	nil)  
    ((7 24)	"由夏 誕生日 (1967)"	nil	nil)
    )
  "User defined holiday association list.
   Format is the same as 'schedule-system-holiday-assoc")

(defvar schedule-face-alist
  '((schedule-workday-face  "yellow" nil nil nil)
    (schedule-saturday-face "cyan" nil nil nil)
    (schedule-holiday-face  "red" nil nil nil))
  "日付の face のリスト
     face名                表示色 背景色 bold italic")

(defvar schedule-use-short-name t
  "Enable to use \"scm\" as an alias of \"schedule\".
  If there's another command named \"scm\", set nil.")

(defvar schedule-scroll-line-p nil
  "Flag if scroll lines when moving cursor.")

(defvar schedule-gengou-p nil
  "Use Japanese GENGOU for year name.")

(defvar schedule-hide-p nil
  "Hide schedule string in the summary buffer or not.")

(defvar schedule-show-borders nil
  "Show border lines between date lines in the summary buffer.")

(defvar schedule-mode-map nil
  "Keymap table for Schedule mode.")

(defvar schedule-edit-mode-map nil
  "Keymap table for Schedule Edit mode.")

(defvar schedule-mode-hook nil
  "Hooks for Schedule mode.")

(defvar schedule-edit-mode-hook nil
  "Hooks for Schedule Edit mode.")

;;
;; 日付行の色の定義
;;
(let ((alist schedule-face-alist) 
      (idx 0)
      entry name fore back bold italic)
  (while (setq entry (nth idx alist))
    (setq name (nth 0 entry)
	  fore (nth 1 entry)
	  back (nth 2 entry)
	  bold (nth 3 entry)
	  italic (nth 4 entry))
    (make-face name)
    (if fore (set-face-foreground name fore))
    (if back (set-face-background name back))
    (if bold (set-face-bold-p name bold))
    (if italic (set-face-italic-p name italic))
    (setq idx (1+ idx))))

;;
;; Interface
;;
(defun schedule (arg)
  "Schedule management tool.
  file format for \"schedule\" is compatible with xcal.
  If ARG is non-nil, schedule ask year and month.
  If ARG is '(quote (16))' (C-u C-u), schedule ask hide or not."
  (interactive "P")
  (let ((config (current-window-configuration))
	time)
    (if (not arg)
	(setq time (schedule-get-time (current-time-string)))
      (setq time (schedule-read-time))
      (and (equal arg '(16))
	   (setq schedule-hide-p (y-or-n-p "Hide schedule?"))))
    (schedule-open time config)))

(and
 schedule-use-short-name
 (defun scm (arg)
   "This command just calls 'schedule.
  Because the command name \"schedule\" is too long, \"scm\" may be
  convenient to activate schedule tool.
  (\"scm\" is an abbreviation of \"SChedule Manager\")"
   (interactive "P")
   (call-interactively 'schedule arg)))

(defun schedule-quit ()
  "Quit from \"schedule\" and restore window configuration."
  (interactive)
  (let ((config schedule-prev-conf))
    (schedule-exit)
    (set-window-configuration config)))

(defun schedule-next-line (arg)
  "Move cursor to the next day."
  (interactive "P")
  (if arg (setq arg (prefix-numeric-value arg))
    (setq arg 1))
  (schedule-forward-line arg))

(defun schedule-prev-line (arg)
  "Move cursor to the previous day."
  (interactive "P")
  (if arg (setq arg (prefix-numeric-value arg))
    (setq arg 1))
  (schedule-forward-line (- arg)))

(defun schedule-forward-page ()
  "Move cursor forward 10 days."
  (interactive)
  (schedule-forward-line 10))

(defun schedule-backward-page ()
  "Move cursor backward 10 days."
  (interactive)
  (schedule-forward-line -10))

(defun schedule-next-month (arg)
  "Goto next month.
   Cursor point will be on the 1th day if ARG is non-nil, else on the
   same day as the current cursor positon."
  (interactive "P")
  (schedule-forward-month 1 arg))

(defun schedule-prev-month (arg)
  "Goto previous month.
   Cursor point will be on the last day if ARG is non-nil, else on the
   same day as the current cursor positon."
  (interactive "P")
  (schedule-forward-month -1 arg))

(defun schedule-jump-month ()
  "Jump to specified month."
  (interactive)
  (let ((time (schedule-read-time))
	(conf schedule-prev-conf))
    (schedule-exit)
    (schedule-open time conf t)))

(defun schedule-toggle-hide (arg)
  "Hide schedule or show (toggle)."
  (interactive "P")
  (setq schedule-hide-p (or arg (not schedule-hide-p)))
  (schedule-open schedule-current-time
		 schedule-prev-conf t))

(defun schedule-kill-data ()
  "Kill current data."
  (interactive)
  (let* ((date (schedule-get-current-date))
	 (file (format schedule-filename-format date))
	 (time schedule-current-time))
    (if (and 
	 (y-or-n-p (format "%d月%d日のデータを消しますか？" (car time) date))
	 (file-exists-p file))
	(progn
	  (schedule-yank-file-contents file)
	  (delete-file file)
	  (schedule-open schedule-current-time
			 schedule-prev-conf t)))
    (message "")))

(defun schedule-yank-data ()
  "Copy current data to yank buffer."
  (interactive)
  (let* ((date (schedule-get-current-date))
	 (file (format schedule-filename-format date))
	 (time schedule-current-time))
    (if (file-exists-p file)
	(progn
	  (schedule-yank-file-contents file)
	  (message "%d月%d日のデータを記憶しました" (car time) date))
      (message "%d月%d日にデータはありません" (car time) date)
      (beep))))

(defun schedule-copy-data ()
  "Copy yank data to current date."
  (interactive)
  (let* ((date (schedule-get-current-date))
	 (file (format schedule-filename-format date))
	 (time schedule-current-time))
    (if (schedule-copy-yanked-contents file)
	(schedule-open schedule-current-time
		       schedule-prev-conf t)
      (message "コピーできません"))))

(defun schedule-edit-schedule ()
  "Open Edit buffer. To return to the summary buffer, type C-cC-c."
  (interactive)
  (let* ((date (or (schedule-get-current-date)
		   (string-to-int (read-string "What day? : "))))
	 (file (format schedule-filename-format date))
	 (time schedule-current-time)
	 (config schedule-prev-conf)
	 (buffer (current-buffer))
	 (pconf (current-window-configuration)))
    (find-file-other-window file)
    (make-local-variable 'schedule-current-time)
    (make-local-variable 'schedule-prev-conf)
    (make-local-variable 'schedule-edit-prev-buffer)
    (make-local-variable 'schedule-edit-prev-conf)
    (setq schedule-current-time (schedule-time-reset time nil nil date)
	  schedule-prev-conf config
	  schedule-edit-prev-buffer buffer
	  schedule-edit-prev-conf pconf)
    (rename-buffer (schedule-edit-buffer-name time date))

    (schedule-edit-mode)))

(defun schedule-edit-copy-data ()
  "Copy yanked data to the current Edit Buffer."
  (interactive)
  (if schedule-yank-variable
      (insert schedule-yank-variable)
    (messsage "データが記憶されていません")))

(defun schedule-edit-quit ()
  "Save data and quit Edit Buffer, then return to the Summary Buffer."
  (interactive)
  (let ((buffer (current-buffer))
	(file (buffer-file-name))
	(require-final-newline t)
	size)
    (schedule-edit-adjust-buffer)
    (setq size (buffer-size))
    (save-buffer)
    (schedule-edit-back-to-summary)
    (kill-buffer buffer)
    (and (zerop size)
	 (file-exists-p file)
	 (delete-file file))))

(defun schedule-edit-cancel ()
  "Kill data and quit Edit Buffer, then return to the Summary Buffer."
  (interactive)
  (let ((buffer (current-buffer))
	(buffer-modified-p nil))
    (schedule-edit-back-to-summary)
    (kill-buffer buffer)))


;;
;; Functions
;;
(defun schedule-open (time config &optional ndwp)
  "Open \"schedule\" Summary Buffer."
  (let* ((month (car time))
	 (year (car (cdr time)))
	 (day (max (min (or (car (cdr (cdr time))) 1)
			(schedule-day-number month year))
		   1))
	 (dir (schedule-get-year-dir year))
	 (fform (schedule-get-filename-format dir year month))
	 (buffer (get-buffer-create
		  (schedule-summary-buffer-name month year))))
    (if (not (file-exists-p schedule-dir))
	(call-process "mkdir" nil nil nil schedule-dir))
    (if (not (file-exists-p dir))
	(call-process "mkdir" nil nil nil dir))
    (if (not (file-directory-p dir))
	(error "%s はディレクトリぢゃないよ" dir)
      (switch-to-buffer buffer)
      (setq buffer-read-only t)
      (let ((buffer-read-only nil))
	(if (not (zerop (buffer-size)))
	    (delete-region (point-min) (point-max)))
	(schedule-make-summary-buffer month year fform)
	(set-buffer-modified-p nil))
      (make-local-variable 'schedule-filename-format)
      (make-local-variable 'schedule-current-time)
      (make-local-variable 'schedule-prev-conf)
      (setq schedule-filename-format fform
	    schedule-current-time time
	    schedule-prev-conf config)
      (or ndwp (delete-other-windows))
      (schedule-move-cursor-on-the-day day)
      (schedule-recenter)
      (schedule-mode))))

(defun schedule-exit ()
  "Kill current Summary Buffer."
  (kill-buffer (current-buffer)))

(defun schedule-make-summary-buffer (month year fform)
  "Make Summary Buffer."
  (let ((dnum (schedule-day-number month year))
	(date 1)
;	(dow (day-of-week month 1 year))
	(dow (schedule-day-of-week month 1 year))
	(mname (if schedule-gengou-p
		   (format "%s年%2d月" (schedule-gengou-year year month) month)
		 (format "%6d年%2d月" year month))))
    ;; title
;;    (insert "          ******* スケジュール  " mname " *******\n")
;;    (insert "------------------------------------------------------------------------\n")
    ;; summary lines
    (while (<= date dnum)
      (schedule-insert-summary-line date month year dow fform)
      (setq date (1+ date))
      (setq dow (% (1+ dow) 7)))
    ;; bottom line
    (and (not schedule-show-borders)
	 (not (= dow 1))
	 (insert "------------------------------------------------------------------------\n")
	 )))

(defun schedule-insert-summary-line (date month year dow fform)
  "Make Summary line."
  (let* ((fname (format fform date))
	 (index (schedule-get-index date month year dow))
	 (idx (car index))
	 (msg (nth 1 index)))

    ; add from nikki.el by TAKEchi
    (put-text-property 0
		       (length idx)
		       'face
		       (cond ((schedule-holiday-p date month year dow)
			      'schedule-holiday-face)
			     ((= dow 6) 'schedule-saturday-face)
			     (t 'schedule-workday-face))
		       idx)

    (save-restriction
      (narrow-to-region (point) (point))
      ;; insert day label and holiday messages.
      (insert idx "\n")
      (mapcar '(lambda (arg) (insert "《" arg "》" "\n")) msg)
;      (while msg
;	(insert "《" (car msg) "》" "\n")
;	(setq msg (cdr msg)))
      ;; insert file contents if file exists.
      (and (file-exists-p fname)
	   (save-restriction
	     (narrow-to-region (point)(point))
	     (schedule-insert-file-contents fname)
;	   (save-excursion (schedule-insert-file-contents fname))
	     (goto-char (point-min))
	     (and schedule-hide-p
		  (while (not (eobp))
		    (let ((beg (point)))
		      (end-of-line)
		      (let ((len (- (point) beg)))
			(delete-region beg (point))
			(while (> len 0)
			  (insert "□") (setq len (- len 2)))  ;;--maki
			(forward-line 1)))))))
      ;; indent
      (goto-char (point-min))
      (end-of-line)
      (delete-char 1)	; join 2 lines
      (indent-rigidly (point) (point-max) (string-width idx))
      (goto-char (point-max))
      (or (bolp) (newline))
      (if (zerop dow)
;;	  (insert "------------------------------------------------------------------------\n")
;;--maki
;;	  (insert "==================================================《"
;;		  (if schedule-gengou-p
;;		      (format
;;		       "%s年%2d月" (schedule-gengou-year year month) month)
;;		    (format "%6d年%2d月" year month))
;;		  "》======\n")
	(and schedule-show-borders
;;	     (insert "------------------------------------------------------------------------\n")
	     )))))
;


(defun schedule-forward-month (arg &optional flag)
  "Goto next ARGth month.
   Cursor point will be on the 1th day if ARG is positive, else on the
   last day of the month.
   If FLAG is non-nil, cursor will move on the same day as the prev. day"
  (let* ((time (schedule-time-month-plus schedule-current-time arg))
	 (month (car time))
	 (year (car (cdr time)))
	 (date (schedule-get-current-date))
	 (config schedule-prev-conf))
    (schedule-exit)
    (schedule-open
     (list (car time)
	   (car (cdr time))
	   (if flag date
	     (if (> arg 0) 1 (schedule-day-number month year))))
     config
     t)))

(defun schedule-forward-line (arg)
  "Goto next ARGth day."
  (let ((date (or (schedule-get-current-date) 1))
	(pnt (point)))
    (if (and (= arg 1) (= date (schedule-day-number
				(car schedule-current-time)
				(car (cdr schedule-current-time)))))
	(schedule-forward-month 1)
      (if (and (= arg -1) (= date 1))
	  (schedule-forward-month -1)
	(progn
	  (setq date (if (> arg 0)
			 (min (+ date arg)
			      (schedule-day-number (car schedule-current-time)
						   (car (cdr schedule-current-time))))
		       (max (+ date arg) 1)))
	  (schedule-move-cursor-on-the-day date)
	  (and schedule-scroll-line-p
	       (condition-case ()
		   (let ((cnt (count-lines (point-min) (point)))
			 (lh (/ (- (window-height) 4) 2)))
		     (if (> arg 0)
			 (and (> cnt lh)
			      (scroll-up (count-lines pnt (point))))
		       (scroll-down (count-lines pnt (point)))))
		 (error ()))))))))

(defun schedule-move-cursor-on-the-day (day)
  "Move cursor on the current day."
  (let ((ptn (if (not day) "^\\(【\\|［\\)01 "
	       (format "^\\(【\\|［\\)%02d " day))))
    (goto-char (point-min))
    (if (re-search-forward ptn nil t)
	(goto-char (match-beginning 0))
	(goto-char (point-min))))
  (setq schedule-current-time
	(schedule-time-reset schedule-current-time nil nil day)))

(defun schedule-recenter ()
  "Similar to 'recenter', but considering window height."
  (let ((ln (count-lines (point) (point-max)))
	(wh (window-height)))
    (if (< (+ ln ln) wh)
	(recenter (- wh ln 1))
      (recenter (/ wh 2)))))

(defun schedule-buffer-exist-p (buffer)
  "BUFFER exists or not."
  (let ((list (buffer-list)) ret)
    (while (and list ret)
      (if (eq (car list) buffer)
	  (setq ret t)
	(setq list (cdr list))))
    ret))

(defun schedule-yank-file-contents (file)
  "Copy FILE contents into schedule-yank-variable."
  (save-excursion
    (let ((buffer (get-buffer-create schedule-temporary-buffer)))
      (set-buffer buffer)
      (widen) (delete-region (point-min) (point-max))
      (schedule-insert-file-contents file)
      (setq schedule-yank-variable
	    (buffer-substring (point-min) (point-max))))))

(defun schedule-copy-yanked-contents (file)
  "Append yanked data to the FILE."
  (if (stringp schedule-yank-variable)
      (save-excursion
	(let ((buffer (get-buffer-create schedule-temporary-buffer)))
	  (set-buffer buffer)
	  (widen) (delete-region (point-min) (point-max))
	  (insert schedule-yank-variable)
	  (append-to-file (point-min) (point-max) file))
	t)
    nil))

(defun schedule-edit-adjust-buffer ()
  "Remove empty lines in the Edit Buffer."
  (goto-char (point-min))
  (replace-regexp "^\n" ""))

(defun schedule-edit-back-to-summary ()
  "Goto Summary Buffer if exists.
  If no Summary Buffer exists, open it."
  (let ((pconf schedule-edit-prev-conf))
    (if (schedule-buffer-exist-p schedule-edit-prev-buffer)
	(schedule-edit-back-to-buffer schedule-edit-prev-buffer)
      (schedule-open schedule-current-time schedule-prev-conf))
    (save-excursion
      (set-window-configuration pconf))
    (schedule-recenter)))

(defun schedule-edit-back-to-buffer (buffer)
  "Switch to BUFFER."
  (set-buffer buffer)
  (pop-to-buffer buffer)
  (schedule-open schedule-current-time schedule-prev-conf))

(defun schedule-insert-file-contents (file)
  "Insert FILE contents."
  (save-restriction
    (narrow-to-region (point) (point))
    (insert-file-contents file)
    (goto-char (point-max))
    (or (zerop (current-column))
	(insert "\n"))
    (goto-char (point-min)) 
    (while (re-search-forward "^[^@]" nil t) ;;--maki
      (forward-char -1)                      ;;--maki
      (kill-line)                            ;;--maki
      (kill-line))                           ;;--maki
    (goto-char (point-min))                  ;;--maki
    (while (re-search-forward "^@" nil t)    ;;--maki
      (delete-char -1))                      ;;--maki
    (while (re-search-forward "^\n" nil t)
      (delete-region (match-beginning 0) (1+ (match-beginning 0))))))


(defun schedule-summary-buffer-name (month year)
  "Get Summary Buffer name."
  (if schedule-gengou-p
      (format "Schedule Buffer {%s年 %d月}"
	      (schedule-gengou-year year month) month)
    (format "Schedule Buffer %d年 %d月" year month)))

(defun schedule-edit-buffer-name (time date)
  "Get Edit Buffer name."
  (if schedule-gengou-p
      (format "Schedule EDIT {%s年%2d月%2d日}"
	      (schedule-gengou-year (nth 1 time) (car time)) (car time) date)
    (format "Schedule EDIT {%2d年%2d月%2d日}"
	    (nth 1 time) (car time) date)))

(defun schedule-get-year-dir (year)
  "Get directory name for YEAR."
  (expand-file-name (format"%s/xy%d" schedule-dir year)))

(defun schedule-get-filename-format (dir year month)
  "Get file-name format (regexp)."
  ;; original xcal format
;  (format "%s/xc%%d%s%d" dir (schedule-int-to-month month) year)
  ;; tacchan@flab's local format
  (format "%s/xc%02d-%02d-%%02d" dir year month)
)

(defun schedule-get-index (date month year &optional dow)
  "Get index string for each day."
  (or dow (setq dow (day-of-week month date year)))
  (let ((hp (schedule-holiday-p date month year dow))
	(hname (schedule-holiday-name date month year)))
    (list (if hp
	      (format "【%02d %s】" date (nth dow schedule-week-name-list))
	    (format "［%02d %s］" date (nth dow schedule-week-name-list)))
	  hname)))

(defun schedule-get-current-date ()
  "Get current day."
  (end-of-line)
  (if (re-search-backward "^\\(【\\|［\\)\\(..\\) " nil t)
      (string-to-int (buffer-substring (match-beginning 2) (match-end 2)))
    (beginning-of-line)
    (if (re-search-forward "^\\(【\\|［\\)\\(..\\) " nil t)
	(string-to-int (buffer-substring (match-beginning 2) (match-end 2)))
      nil)))

;;
;; Time functions
;;
(defun schedule-read-time ()
  "Ask user year and month."
  (let* ((time (schedule-get-time (current-time-string)))
	 (year (read-string "何年？ : " (int-to-string (car (cdr time)))))
	 (month (read-string "何月？ : " (int-to-string (car time)))))
    (if (string-equal month "")
	(setq month (car time))
      (setq month (string-to-int month)))
    (if (string-equal year "")
	(setq year (car (cdr time)))
      (setq year (string-to-int year)))
    (list month year 1)))

(defun schedule-get-time (str)
  "Make time list by TIMESTRING.
    such as '(month year day)."
  (let ((month (substring str 4 7))
	(year (substring str 20 24))
	(day (substring str 8 10)))
    (list (schedule-month-to-int month)
	  (string-to-int year)
	  (string-to-int day))))

(defun schedule-time-reset (time month year day)
  "Make \"time\" list."
  (let ((mnth (car time))
	(yr (nth 1 time))
	(dy (nth 2 time)))
    (list (or month mnth) (or year yr) (or day dy))))
	
(defun schedule-month-to-int (month)
  "Get month from month-name."
  (cdr (assoc month
	      '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4)
		("May" . 5) ("Jun" . 6) ("Jul" . 7) ("Aug" . 8)
		("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)))))

(defun schedule-int-to-month (month)
  "Get month-name from month."
  (nth (1- month)
       '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
	 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))

(defun schedule-time-month-plus (time plus)
  "Calculate \"time\" + PLUS months."
  (let ((month (+ (car time) plus))
	(year (car (cdr time)))
	(rest (cdr (cdr time))))
    (while (< month 1)
      (setq month (+ month 12))
      (setq year (1- year)))
    (while (> month 12)
      (setq month (- month 12))
      (setq year (1+ year)))
    (cons month (cons year rest))))

(defun schedule-day-number (month year)
  "Get number of the day for each month."
  (if (and (= month 2) (schedule-uruu-p year))
      29
    (nth (1- month)
	 '(31 28 31 30 31 30 31 31 30 31 30 31))))

(defun schedule-get-holiday (date month year alist)
  "Get holiday alist."
  (let ((alst alist) lst)
    (while alst
      (let* ((data (car alst))
             (ydata (car (cdr (cdr data)))))
        (and (equal (car data) (list month date))
             (or (not ydata) (= ydata year))
             (setq lst (cons (list (car (cdr data))
                                   (car (cdr (cdr (cdr data))))) lst)))
        (setq alst (cdr alst))))
    lst))

(defun schedule-holiday-name (date month year)
  "Get holiday name."
  (let (data list)
    (setq data (schedule-get-holiday
		date month year schedule-user-holiday-assoc))
    (while data
      (let ((ndata (car data)))
        (and (car ndata)
             (setq list (cons (car ndata) list))))
      (setq data (cdr data)))
    (setq data (schedule-get-holiday
		date month year schedule-system-holiday-assoc))
    (while data
      (let ((ndata (car data)))
        (and (car ndata)
             (setq list (cons (car ndata) list))))
      (setq data (cdr data)))
    list))

;(defun schedule-holiday-p (date month year &optional dow)
;  "Holiday (= non work day) or not."
;  (or dow (setq dow (day-of-week month day year)))
;  (let ((ret (or (zerop dow) (= 6 dow)))
;        data)
;    (setq data (schedule-get-holiday
;                  date month year schedule-system-holiday-assoc))
;    (while data
;      (if (not (car (cdr (car data))))
;          (setq data (cdr data))
;        (setq ret t)
;        (setq data nil)))
;    (setq data (schedule-get-holiday
;                  date month year schedule-user-holiday-assoc))
;    (while data
;      (let ((ndata (car data)))
;        (if (car ndata)
;	    (progn
;	      (and (car (cdr ndata))
;		   (setq ret t))
;	      (setq data (cdr data)))
;          (setq ret (car (cdr ndata)))
;          (setq data nil))))
;    ret))
(defun schedule-holiday-p (date month year &optional dow)
  "Holiday (= non work day) or not."
  (or dow (setq dow (schedule-day-of-week month day year)))
  (let ((ret (or (zerop dow)))
        data)
    (setq data (schedule-get-holiday-data
                  date month year schedule-system-holiday-assoc))
    (while data
      (if (not (car (cdr (car data))))
          (setq data (cdr data))
        (setq ret t)
        (setq data nil)))
    (setq data (schedule-get-holiday-data
                  date month year schedule-user-holiday-assoc))
    (while data
      (let ((ndata (car data)))
        (if (car ndata)
	    (progn
	      (and (car (cdr ndata))
		   (setq ret t))
	      (setq data (cdr data)))
          (setq ret (car (cdr ndata)))
          (setq data nil))))
    ret))

;add from nikki.el by TAKEchi
(defun schedule-get-holiday-data (date month year alist)
  "Get holiday list."
  (let ((alst alist) lst)
    (while alst
      (let* ((data (car alst))
             (ydata (car (cdr (cdr data)))))
        (and (equal (car data) (list month date))
             (or (not ydata) (= ydata year))
             (setq lst (cons (list (car (cdr data))
                                   (car (cdr (cdr (cdr data))))) lst)))
        (setq alst (cdr alst))))
    lst))
;add from nikki.el by TAKEchi
(defun schedule-holiday-name (date month year)
  "Get holiday name."
  (let (data list)
    (setq data (schedule-get-holiday-data
		date month year schedule-user-holiday-assoc))
    (while data
      (let ((ndata (car data)))
        (and (car ndata)
             (setq list (cons (car ndata) list))))
      (setq data (cdr data)))
    (setq data (schedule-get-holiday-data
		date month year schedule-system-holiday-assoc))
    (while data
      (let ((ndata (car data)))
        (and (car ndata)
             (setq list (cons (car ndata) list))))
      (setq data (cdr data)))
    list))


(defun schedule-uruu-p (year)
  "Uruu-doshi or not."
  (zerop (% year 4)))

(defun schedule-gengou-year (year month)
  "Get Japanese Gengou year."
  (if (< year 1926) (format "%6d" year)
    (if (= year 1926)
	(if (< month 12) "大正15" "昭和元")
      (if (< year 1989) (format "昭和%2d" (- year 1925))
	(if (= year 1989)
	    (if (= month 1) "昭和64" "平成元")
	  (format "平成%2d" (- year 1988)))))))
;;
;; Mode Definitions
;;
(defun schedule-mode ()
  "Major mode for \"schedule\" Summary Buffer."
  (setq schedule-mode-map (schedule-make-default-keymap))
  (use-local-map schedule-mode-map)
  (setq major-mode 'schedule-mode)	;; --tsekine
  (setq mode-name "Schedule")		;; --tsekine
  (and schedule-mode-hook
       (run-hooks 'schedule-mode-hook)))

(defun schedule-make-default-keymap ()
  "Make default keymap for \"schedule\"Summary mode."
  (let ((map (make-keymap)))
    (suppress-keymap map)
    (define-key map "c" 'schedule-copy-data)
    (define-key map "d" 'schedule-kill-data)
;    (define-key map "e" 'schedule-edit-schedule)
    (define-key map "\C-m" 'schedule-edit-schedule)
    (define-key map "h" 'schedule-toggle-hide)
    (define-key map "j" 'schedule-jump-month)
    (define-key map "n" 'schedule-next-line)
    (define-key map "N" 'schedule-forward-page)
    (define-key map "p" 'schedule-prev-line)
    (define-key map "P" 'schedule-backward-page)
    (define-key map "q" 'schedule-quit)
    (define-key map "y" 'schedule-yank-data)
;    (define-key map "\C-m" 'schedule-next-month)
    (define-key map " " 'schedule-next-month)
    (define-key map "\e\C-m" 'schedule-prev-month)
    (define-key map "" 'schedule-prev-month)
    (define-key map "\C-c\C-c" 'schedule-quit)
    map))

(defun schedule-edit-mode ()
  "Major mode for \"schedule\" Edit Buffer."
  (setq schedule-edit-mode-map (schedule-edit-make-default-keymap))
  (use-local-map schedule-edit-mode-map)

  (enlarge-window (- (window-height) 5)) ;;-maki

  (and schedule-edit-mode-hook
       (run-hooks 'schedule-edit-mode-hook)))

(defun schedule-edit-make-default-keymap ()
  "Make default keymap for \"schedule\" Edit mode."
  (let ((map (make-keymap)))
    (define-key map "\^C\^C" 'schedule-edit-quit)
    (define-key map "\^C\^Q" 'schedule-edit-cancel)
    (define-key map "\^C\^Y" 'schedule-edit-copy-data)
    map))

(defun schedule-day-of-week (month day year)
  (let* ((ly (if (schedule-uruu-p year) 1 0))
	 (dn (- (+ day (* 31 (1- month)))
		(if (> month 2) (- (/ (+ 23 (* 4 month)) 10) ly) 0)))
	 (cr (* (/ (1- year) 100) 3))
	 (adn (- (+ dn (* 365 (1- year)) (/ (1- year) 4))
		 (if (zerop (% cr 4)) (/ cr 4) (1+ (/ cr 4))))))
    (% adn 7)))