;;; -*- Mode: Emacs-Lisp -*- ;;; $Id: xcal-20.el,v 1.15 1998/05/12 09:38:53 tsumura Exp tsumura $ ;;; ;;; Copyleft (C) TSUMURA Tomoaki 1997 ;;; ;;; e-mail: tsumura@kuis.kyoto-u.ac.jp ;;; ;;; *** for lab3 only!! ;;; *** 持ち出し厳禁 !! ;;(99/12/01:okamoto) Meadow 1.10に対応 ;;(99/02/24:aoki) 西暦 2000 年以降の成人の日，体育の日に対応 ;;(99/02/24:aoki) Mule fo Win32, Meadow でも face ;;(98/08/19:tsumura) xcal-calendar-today-face 作成 ;;(98/05/12:tsumura) xcal-vi-like-key-assign の def を nil に (五島さん対策) ;;(98/02/10:tsumura) しょーもない bug fix ;;(98/01/29:tsumura) xcal-vi-like-key-assign を作成 (舟本要求) ;;(98/01/23:tsumura) mini calendar の幅決めるとこの bug (舟本報告) を fix ;;(98/01/21:tsumura) XEmacs で scroll-bar つきでも、mini calendar ちゃんと表示 ;; mini calendar の buffer の折り返しを制御すればもっと楽？ ;;(98/01/20:tsumura) menu に日本語つかうな！ ;;(98/01/20:tsumura) mini calendar の window 幅、scroll-bar の有無で分岐 ;;(98/01/07:tsumura) スケジュールの取り込みなんて誰もやらんだろうから cut ;;(98/01/07:tsumura) xcal-alarm-prog の default値 修正 ;;(97/12/19:tsumura) xcal-show-calendar の default を t に ;;(97/12/19:tsumura) xcal-japanese-weekday-vector 作成 ;;(97/12/18:tsumura) mini calendar の曜日表示を日本語に ;;(97/12/18:tsumura) face 'region の有無 check を修正 ;;(97/12/18:tsumura) xcal-lookup-face-create を default-underline に対応 ;;(97/12/18:tsumura) XEmacs でナゼか face が変になるのを修正 ;;(97/12/18:tsumura) (if (not ...) は カッコ悪いから やめ ;;(97/12/18:tsumura) face 'region がない場合、'modeline で代替 ;;(97/12/18:tsumura) comment 大幅 cut ;;(97/12/18:tsumura) cal.el 依存を排除、代わりに calendar.el を使う。 ;;(97/12/17:tsumura) Ver 1.1 Emacs20/XEmacs 対応 ;;(97/12/17:tsumura) hilit19.el 依存を排除 ;;(97/12/17:tsumura) XEmacs における marker のずれを(無理やり)修正 ;;(96/01/07:morimoto)Ver 1.01 ;;; original program xcal-19.el is created by ;;; Shigeki Morimoto ;;; mori@freedom.co.jp ;;; How to use ;; (1) add your ~/.emacs ;; (autoload 'xcal "xcal-20" "xcal for emacs." t) ;; (2) type ``M-x xcal'' (require 'calendar) (defvar xcal-alarm-proc nil) (defvar xcal-alarm-prog "/usr/local/share/mule2/site-lisp/misc/xcal-alarm") (defvar xcal-alarm-countdown "0,5,10" "何分前にアラームを出すか , で区切って指定する") (defvar xcal-alarm-update "10" "スケージュールを読み直す間隔(秒)") (defvar xcal-directory "~/Calendar" "*xcal の カレンダーディレクトリー") (defvar xcal-schedule-xcalndar-compatible nil "t に設定すると xcalendar とコンパチのスケジュールファイルをアクセスします") (defvar xcal-print-out-command nil "カレンダーを出力するコマンド。標準入力から読み込むもの... default は `lpr'") (defvar xcal-disp-holiday nil "カレンダーに祝日を表示するかどうか") (defvar xcal-week-holiday '((0 red) (6 blue)) "*一週間のいつが休みか & 表示色 日曜:0 .... 土曜:6") (defvar xcal-japanese-weekday-vector '["日" "月" "火" "水" "木" "金" "土"]) (defvar xcal-holiday-alist '(( 1 ( 1 . "元旦")) ( 2 (11 . "建国記念の日")) ( 4 (29 . "緑の日")) ( 5 ( 3 . "憲法記念日") ( 4 . "国民の祝日") ( 5 . "子供の日")) ( 7 (20 . "海の日")) ; added by Tsumura, and it's my birthday! ( 9 (15 . "敬老の日")) (11 ( 3 . "文化の日") (23 . "勤労感謝の日")) (12 (23 . "天皇誕生日"))) "*祝日のリスト (月 (日 . \"何の日\")) または (月 (日 . (\"何の日\" 曜日の色 名称の色))) (月 (日 \"何の日\" 曜日の色 名称の色)) の形式です。") (defvar xcal-auto-holiday-alist nil "春分・秋分などの自動生成した祝日のリスト") (defvar xcal-memorial-day-alist '((11 (23 . "感謝祭")) (12 (24 . "Xmas イブ")(25 . "Xmas"))) "*記念日のリスト") (defvar xcal-schedule-color-list '( ("休日" red nil) ("盆休み" red nil) ("納期" green red) ("^\\*[0-9]+:[0-9].*$" nil blue) ; *hh:mm で勤務時間を設定 (別プログラムで勤怠表作成) ("^.*誕生日" nil DarkGreen) ) "スケジュールの内容で 曜日の色とスケジュールの色を変更します") ;; 休日の時の曜日の色 (defvar xcal-holiday-week-color 'red) (defvar xcal-show-calendar t "calendar.el の Calendar をひょーじするかどうか") (defvar xcal-file nil "カレンダーのファイル") (defvar xcal-days nil "その月が何日までか") (defvar xcal-day-markers nil "日にちのマーカー") (defvar xcal-day-schedule nil) (defvar xcal-current-year nil) (defvar xcal-current-month nil) (defvar xcal-current-day nil) (defvar xcal-month-offset 0) (defvar xcal-map nil "XCal の キーマップ") (defvar xcal-map-hook nil) (defvar xcal-edit-mode-map nil "XCal の エディットモードのキーマップ") (defvar xcal-edit-mode-map-hook nil) (defvar xcal-keys-message nil "下に表示するキーバインド") (defvar xcal-previous-window-configuration nil) (defvar xcal-copy-buffer nil) (defvar xcal-selected nil) (defvar xcal-alarm-all-ret nil) (defvar xcal-alarm-ret nil) (defvar xcal-vi-like-key-assign nil "vi 風の key bind にするか") (or (member 'region (face-list)) ; XEmacs has no 'region face! (copy-face 'modeline 'region)) ; ほんまか？ ;; ;; ;; (defun xcal-before () "前月のひょーじ" (interactive) (xcal-1 (1- xcal-month-offset))) (defun xcal-next () "次月のひょーじ" (interactive) (xcal-1 (1+ xcal-month-offset))) (defun xcal-toggle-disp-holiday () "祝日のひょーじの ON/OFF" (interactive) (setq xcal-disp-holiday (not xcal-disp-holiday)) (xcal-refresh)) (defun xcal-toggle-show-calendar () "前後 ３ヶ月のカレンダーのひょーじ ON/OFF" (interactive) (setq xcal-show-calendar (not xcal-show-calendar)) (xcal-refresh)) (defun xcal-edit-mode () " XCal のふぁいるのへんしゅー \\{xcal-edit-mode-map} " (if (null xcal-edit-mode-map) (progn (setq xcal-edit-mode-map (copy-keymap text-mode-map)) (define-key xcal-edit-mode-map "\C-c\C-c" 'xcal-edit-cease-edit) (define-key xcal-edit-mode-map "\C-x\C-s" 'xcal-edit-cease-edit) (define-key xcal-edit-mode-map "\C-c\C-]" 'xcal-edit-abort-edit)) (and xcal-edit-mode-map-hook (run-hooks 'xcal-edit-mode-map-hook))) (use-local-map xcal-edit-mode-map) (setq major-mode 'xcal-edit-mode) (setq mode-name "XCal Edit")) (defun xcal-edit-for-xcal () (interactive) (if (get-buffer "*XCal Edit*") (progn (set-buffer (get-buffer "*XCal Edit*")) (xcal-edit-cease-edit t))) (set-buffer (get-buffer-create "*XCal Edit*")) (erase-buffer) (select-window (split-window-vertically (/ (window-height) 2))) (switch-to-buffer "*XCal Edit*") (xcal-edit-mode) (setq buffer-read-only nil) (set-buffer-modified-p (buffer-modified-p)) (setq mode-line-process (format "(%d/%d/%d)" xcal-current-year xcal-current-month xcal-current-day)) (setq xcal-file (xcal-file-name xcal-current-year xcal-current-month xcal-current-day)) (and (file-exists-p xcal-file) (insert-file xcal-file)) (message (substitute-command-keys "Editing: Type \\[xcal-edit-cease-edit] to return to XCal, \\[xcal-edit-abort-edit] to abort."))) (defun xcal-edit-cease-edit (&optional do-not-refresh) (interactive) (goto-char (point-max)) (delete-blank-lines) (if (= (point-min) (point-max)) (and (file-exists-p xcal-file) (delete-file xcal-file)) (xcal-write-region (point-min) (point-max) xcal-file)) (let (win) (setq win (get-buffer-window (current-buffer))) (kill-buffer (current-buffer)) (if win (progn (select-window win) (delete-window)))) (or do-not-refresh (xcal-refresh))) (defun xcal-edit-abort-edit () (interactive) (kill-buffer (current-buffer)) (delete-window)) (defun xcal-quit () (interactive) (kill-buffer "*XCal*") (and (get-buffer "*XCal-Calendar*") (kill-buffer "*XCal-Calendar*")) (and (get-buffer "*XCal-Edit*") (kill-buffer "*XCal-Edit*")) (set-window-configuration xcal-previous-window-configuration)) (defun xcal-delete-file () (interactive) (let ((file (xcal-file-name xcal-current-year xcal-current-month xcal-current-day))) (and (file-exists-p file) (y-or-n-p (format "%s/%s/%s のスケジュールを消去します。" xcal-current-year xcal-current-month xcal-current-day)) (progn (delete-file file) (xcal-refresh)))) (xcal-show-keys)) (defun xcal-previous-day () (interactive) (xcal-goto-day (1- xcal-current-day))) (defun xcal-next-day () (interactive) (xcal-goto-day (1+ xcal-current-day))) (defun xcal-goto-top-day () (interactive) (xcal-goto-day 1)) (defun xcal-goto-last-day () (interactive) (xcal-goto-day xcal-days)) (defun xcal-scroll-up () (interactive) (scroll-up) (let ((day 1)(p (point))) (while (and (<= day xcal-days) (< (aref xcal-day-markers day) p)) (setq day (1+ day))) (xcal-goto-day day))) (defun xcal-scroll-down () (interactive) (scroll-down) (let ((day xcal-days)(p (point))) (while (and (<= 1 day) (> (aref xcal-day-markers day) p)) (setq day (1- day))) (xcal-goto-day day))) (defun xcal-mouse-set-point (event) (interactive "e") (mouse-set-point event) (end-of-line) (let ((day 1)(p (point))) (while (and (<= day xcal-days) (< (aref xcal-day-markers day) p)) (setq day (1+ day))) (xcal-goto-day (1- day)))) (defun xcal-mouse-set-point-edit (event) (interactive "e") (xcal-mouse-set-point event) (xcal-edit-for-xcal)) (defun xcal-next-schedule () (interactive) (let ((day (1+ xcal-current-day))) (while (<= day xcal-days) (if (aref xcal-day-schedule day) (progn (xcal-goto-day day) (setq day (+ xcal-days 1000)))) ; ださい ？ (setq day (1+ day))))) (defun xcal-previous-schedule () (interactive) (let ((day (1- xcal-current-day))) (while (<= 1 day) (if (aref xcal-day-schedule day) (progn (xcal-goto-day day) (setq day 0))) (setq day (1- day))))) (defun xcal-jump () (interactive) (let (date ymd year month now-year now-month) (setq date (read-string "(/mm) or (yyyy/mm) or (yyyy) ? ")) (if (and (null (string-match "^[(]?\\([0-9]*\\)/\\([0-9]+\\)[)]?$" date)) (null (string-match "^[(]?\\([0-9]+\\)[)]?$" date))) (error "illegal format !")) (setq year (string-to-int (substring date (match-beginning 1)(match-end 1)))) (if (= (match-beginning 1)(match-end 1)) ; (isoyama) (setq year xcal-current-year)) (if (match-beginning 2) (setq month (string-to-int (substring date(match-beginning 2)(match-end 2)))) (setq month 1)) (if (or (< month 1)(< 12 month)) (error (format "%d月なんかないよ！" month))) (setq ymd (get-year-month-day)) (setq now-year (car ymd)) (setq now-month (car (cdr ymd))) (xcal-1 (+ (* (- year now-year) 12) (- month now-month))))) (defun xcal-copy-schedule () (interactive) (setq xcal-copy-buffer (list xcal-current-year xcal-current-month xcal-current-day)) (message "スケジュールをコピーしました")) (defun xcal-yank-schedule () (interactive) (if (null xcal-copy-buffer) (error "スケジュールがコピーされていません") (let (year month day srcFile dstFile temp-buffer buffer-read-only) (setq year (nth 0 xcal-copy-buffer)) (setq month (nth 1 xcal-copy-buffer)) (setq day (nth 2 xcal-copy-buffer)) (setq srcFile (xcal-file-name year month day)) (or (file-exists-p srcFile) (error "コピー元のスケジュールがありません")) (setq dstFile (xcal-file-name xcal-current-year xcal-current-month xcal-current-day)) (if (and (file-exists-p dstFile) (y-or-n-p "上書きしますか？ (n で追加)")) (delete-file dstFile)) (setq temp-buffer (get-buffer-create "*XCal-temp*")) (set-buffer temp-buffer) (setq buffer-read-only nil) (erase-buffer) (insert-file srcFile) (if (file-exists-p dstFile) (insert-file dstFile)) (xcal-write-region (point-min) (point-max) dstFile) (xcal-refresh) ))) (defun xcal-mode () "\ XCal だっ！ X11 の xcal みたいなやつ \\{xcal-map} " (if (null xcal-map) (progn (setq xcal-map (make-keymap)) (if window-system (progn (setq xcal-mouse-3-map (make-sparse-keymap "XCal")) (define-key xcal-map [down-mouse-3] xcal-mouse-3-map) (define-key xcal-mouse-3-map [exit-xcal] '("Exit" . xcal-quit)) (define-key xcal-mouse-3-map [scroll-backward] '("Scroll backward" . xcal-scroll-down)) (define-key xcal-mouse-3-map [scroll-forward] '("Scroll forward" . xcal-scroll-up)) (define-key xcal-mouse-3-map [minical] '("Mini Calendar" . xcal-toggle-show-calendar)) (define-key xcal-mouse-3-map [holiday] '("Holiday" . xcal-toggle-disp-holiday)) (define-key xcal-map [next] '("Next Month" . xcal-next)) (define-key xcal-map [before] '("Before Month" . xcal-before)) (define-key xcal-map [menu-bar disp] (cons "Display" (make-sparse-keymap "display"))) (define-key xcal-map [menu-bar disp minical] '("Mini Calendar" . xcal-toggle-show-calendar)) (define-key xcal-map [menu-bar disp holiday] '("Holiday" . xcal-toggle-disp-holiday)) (define-key xcal-map [menu-bar next] '("Next" . xcal-next)) (define-key xcal-map [menu-bar before] '("Prev" . xcal-before)) (define-key xcal-map [mouse-1] 'xcal-mouse-set-point) (define-key xcal-map [double-mouse-1] 'xcal-mouse-set-point-edit) )) ; (if xcal-map-hook ; (run-hooks 'xcal-map-hook) (or (and xcal-vi-like-key-assign (define-key xcal-map "h" 'xcal-before) (define-key xcal-map "l" 'xcal-next) (define-key xcal-map "k" 'xcal-previous-day) (define-key xcal-map "j" 'xcal-next-day) (define-key xcal-map "J" 'xcal-next-schedule) (define-key xcal-map "K" 'xcal-previous-schedule)) (and (define-key xcal-map "<" 'xcal-before) (define-key xcal-map ">" 'xcal-next) (define-key xcal-map "p" 'xcal-previous-day) (define-key xcal-map "n" 'xcal-next-day) (define-key xcal-map "N" 'xcal-next-schedule) (define-key xcal-map "P" 'xcal-previous-schedule))) (define-key xcal-map "~" 'xcal-1) (define-key xcal-map "." 'xcal-1) (define-key xcal-map "e" 'xcal-edit-for-xcal) (define-key xcal-map "w" 'xcal-edit-for-xcal-week) (define-key xcal-map "d" 'xcal-delete-file) (define-key xcal-map "q" 'xcal-quit) (define-key xcal-map "\C-v" 'xcal-scroll-up) (define-key xcal-map " " 'xcal-scroll-up) (define-key xcal-map "\M-v" 'xcal-scroll-down) (define-key xcal-map "\C-?" 'xcal-scroll-down) (define-key xcal-map "t" 'xcal-toggle-disp-holiday) (define-key xcal-map "\M-<" 'xcal-goto-top-day) (define-key xcal-map "\M->" 'xcal-goto-last-day) (define-key xcal-map "s" 'xcal-toggle-show-calendar) ; (define-key xcal-map "J" 'xcal-jump) ;original (define-key xcal-map "\M-j" 'xcal-jump) ;for vi-like (define-key xcal-map "\M-w" 'xcal-copy-schedule) (define-key xcal-map "\C-y" 'xcal-yank-schedule) (run-hooks 'xcal-map-hook) ;(94/11/10:isoyama) )) (use-local-map xcal-map) (setq truncate-lines t) (setq major-mode 'xcal-mode) (setq mode-name "XCal")) (defun xcal (&optional month-offset) "xcal みたいな感じで、Calendar を表示する。" (interactive "P") (setq xcal-previous-window-configuration (current-window-configuration)) (and (get-buffer "*XCal-Calendar*") (kill-buffer "*XCal-Calendar*")) (and (get-buffer "*XCal-Edit*") (kill-buffer "*XCal-Edit*")) (and xcal-alarm-prog ;(94/11/10:isoyama) (eq window-system 'x) (xcal-alarm-start--proc)) (xcal-1 month-offset)) (defun xcal-1 (&optional month-offset) "xcal の 本体" (interactive "P") (if month-offset (setq month-offset (prefix-numeric-value month-offset))) (set-buffer (get-buffer-create "*XCal*")) (switch-to-buffer "*XCal*") (xcal-mode) (delete-other-windows) (setq buffer-read-only t) (and xcal-show-calendar (xcal-show-calendar-horizontal month-offset)) (let* ((buffer-read-only nil) (ymd (get-year-month-day)) year month day) (setq year (car ymd)) (setq month (car (cdr ymd))) (setq day (cond ((or (null month-offset)(= 0 month-offset)) (car (cdr (cdr ymd)))) (t nil))) (if (null month-offset) (setq xcal-month-offset 0) (setq xcal-month-offset month-offset)) (and month-offset (let ((year-month (+ (+ (* year 12) (- month 1)) month-offset))) (setq month (+ (% year-month 12) 1)) (setq year (/ year-month 12)))) (setq xcal-current-year year) (setq xcal-current-month month) (setq xcal-current-day (or day 1)) (setq mode-line-process (format "(%d/%d)" xcal-current-year xcal-current-month)) (erase-buffer) (xcal-generate-month month year day)) (xcal-goto-day xcal-current-day) (xcal-show-keys)) (defun xcal-generate-calendar-month (month year indent day) ;; This function algorithm is stolen from generate-calendar-month in calendar.el ;; by TSUMURA (let* ((blank-days (mod (- (calendar-day-of-week (list month 1 year)) calendar-week-start-day) 7)) (last (calendar-last-day-of-month month year)) (pos)) (calendar-insert-indented (calendar-string-spread (list "" (format "%s %d" (calendar-month-name month) year) "") ? 20) indent t) (calendar-insert-indented "" indent);; Go to proper spot (calendar-for-loop i from 0 to 6 do (insert (aref xcal-japanese-weekday-vector (mod (+ calendar-week-start-day i) 7))) (insert " ")) (calendar-insert-indented "" 0 t);; Force onto following line (calendar-insert-indented "" indent);; Go to proper spot (calendar-for-loop i from 1 to blank-days do (insert " ")) (calendar-for-loop i from 1 to last do (if (eq i day) (setq pos (1+ (point)))) (insert (format "%2d " i)) (put-text-property (- (point) (if (< i 10) 2 3)) (1- (point)) 'highlight t) (and (zerop (mod (+ i blank-days) 7)) (/= i last) (calendar-insert-indented "" 0 t) (calendar-insert-indented "" indent))) pos)) (defun xcal-generate-month (month year &optional today) "カレンダーのひょーじ" (let* ((week (calendar-day-of-week (list month 1 year))) (last-of-month (if (and (calendar-leap-year-p year) (= month 2)) 29 (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) (month-name ; (aref ["January" "February" "March" "April" "May" "June" ; "July" "August" "September" "October" "November" "December"] ; (1- month)) (aref ["1月" "2月" "3月" "4月" "5月" "6月" "7月" "8月" "9月" "10月" "11月" "12月"] (1- month)) ;(isoyama) ) info msg tmpMsg (xcal-buffer (current-buffer)) (temp-buffer (get-buffer-create "*XCal-temp*"))) (setq xcal-days last-of-month) (setq xcal-day-markers (make-vector (1+ xcal-days) nil)) (setq xcal-day-schedule (make-vector (1+ xcal-days) nil)) (setq last-of-month (1+ last-of-month)) ;; 自動生成祝日リストの作成 (if (or (null xcal-auto-holiday-alist) (/= year (car xcal-auto-holiday-alist))) (setq xcal-auto-holiday-alist (xcal-make-auto-holiday-alist year))) (put-text-property (point-min) (point-max) 'face 'none) (insert-string (format " %d年 %s\n" year month-name)) (let ((day 1) (week-face nil)) (while (< day last-of-month) (xcal-make-underline) (aset xcal-day-markers day (make-marker)) (cond ((setq info (or (assoc day (cdr (assoc month xcal-holiday-alist))) (assoc day (cdr (assoc month xcal-auto-holiday-alist))))) ;; 祝日 (or (listp (cdr info)) (setq info (list nil (cdr info) nil xcal-holiday-week-color))) (setq msg (copy-sequence (nth 1 info))) (setq week-face (xcal-lookup-face-create (or (nth 2 info) xcal-holiday-week-color))) (if (nth 3 info) (put-text-property 0 (length msg) 'face (xcal-lookup-face-create (nth 3 info)) msg))) ((assoc week xcal-week-holiday) ;; 土日かも (setq msg nil) (setq week-face (xcal-lookup-face-create (nth 1 (assoc week xcal-week-holiday))))) ((and (= week 1) (or (assoc (1- day) (cdr (assoc month xcal-holiday-alist))) (assoc (1- day) (cdr (assoc month xcal-auto-holiday-alist))))) (setq msg "振替休日") (setq week-face (xcal-lookup-face-create xcal-holiday-week-color))) (t ;; なんもなし (setq msg nil) (setq week-face nil))) (if (setq info (assoc day (cdr (assoc month xcal-memorial-day-alist)))) ;; 記念日 (progn (or (listp (cdr info)) (setq info (list nil (cdr info) nil xcal-holiday-week-color))) (setq tmpMsg (copy-sequence (nth 1 info))) (setq week-face (xcal-lookup-face-create (or (nth 2 info) xcal-holiday-week-color))) (if (nth 3 info) (put-text-property 0 (length tmpMsg) 'face (xcal-lookup-face-create (nth 3 info)) tmpMsg)) (setq msg (concat (or msg "") (and msg "\n") tmpMsg)))) (if msg (setq msg (concat msg "\n"))) ;(94/11/17:isoyama) ;; 祝日は表示しません (and (null xcal-disp-holiday)(setq msg nil)) (let (buffer-read-only file prefix x-prefix now) ;; テンポラリのバッファに移る (switch-to-buffer temp-buffer) (setq buffer-read-only nil) (erase-buffer) ;; あれば その日の情報を (and msg (insert msg "\n")) ;; スケジュールを (setq file (xcal-file-name year month day)) (if (file-exists-p file) (progn (aset xcal-day-schedule day t) (insert-file file) ;; スケジュールのマッチング処理 (let (i regexp week-color schedule-color) (setq i 0) (while (< i (length xcal-schedule-color-list)) (setq regexp (nth 0 (nth i xcal-schedule-color-list))) (setq week-color (nth 1 (nth i xcal-schedule-color-list))) (setq schedule-color (nth 2 (nth i xcal-schedule-color-list))) (while (re-search-forward regexp nil t) (and schedule-color (put-text-property (match-beginning 0) (match-end 0) 'face (xcal-lookup-face-create schedule-color))) (and week-color (setq week-face (xcal-lookup-face-create week-color))) ) (setq i (1+ i)))) )) ;; 最後の改行を処理 (goto-char (point-max)) (insert "\n\n") (delete-blank-lines) ;; 空なら "\n" を追加 (goto-char (point-min)) (if (eobp) (insert "\n")) ;; 日付を設定 (setq prefix (concat (format "%2d " day) (let (str) ;; 曜日表示をかえた(isoyama) (setq str (copy-sequence (aref xcal-japanese-weekday-vector week))) str) " " (if (and today (= today day)) "*" "|"))) (put-text-property 0 (length prefix) 'face 'default prefix) (if week-face (put-text-property 3 (- (length prefix) 2) 'face week-face prefix)) (setq x-prefix (concat (make-string (1- (clength prefix)) ? ) "|")) (put-text-property 0 (length x-prefix) 'face 'default x-prefix) (goto-char (point-min)) (while (not (eobp)) (beginning-of-line) (insert prefix) (setq prefix x-prefix) (next-line 1)) (setq msg (buffer-string)) (switch-to-buffer xcal-buffer) (setq now (point)) (insert-string msg) (if (or (featurep 'xemacs) (featurep 'meadow)) ;; by okamoto-san (goto-char (- (+ now (clength prefix)) 2)) (goto-char (+ now (clength prefix)))) (setq marker (set-marker (aref xcal-day-markers day) (point))) (goto-char (point-max)) ) (setq week (1+ week)) (if (<= 7 week) (setq week 0)) (setq day (1+ day))) (xcal-make-underline)) (kill-buffer temp-buffer))) (defun xcal-make-underline () (let (start end len) (previous-line 1) (beginning-of-line)(setq start (point)) (end-of-line) (setq len (clength (buffer-substring start (point)))) (if (<= (- (window-width) 2) len) (setq len (- (window-width) 2))) (end-of-line) (insert (make-string (- (window-width) 2 len) ? )) (end-of-line) (let (s e x this face) (setq s start) (setq e (point)) (while (< s e) (setq this (get-text-property s 'face)) (setq face (if this (intern (concat (symbol-name this) "-underline")) 'underline)) (setq x (or (next-single-property-change s 'face) e)) (put-text-property s x 'face (xcal-lookup-face-create face)) (setq s x))) (next-line 1))) (defun xcal-file-name (year month day) "年月日からファイル名を作成する。 Unix : {Calnedar}/xy{年}/xc{日}{月(文字)}{年} 1999/1/1 -> ~/Calnedar/xy1991/xc1Jan1991 xcal-schedule-xcalndar-compatible が設定されていれば 1999/1/1 -> ~/Calnedar/xc1Jan1991 Dos : {Calnedar}/xy{年}/xc{年(%04d)}{月(%02d)}.{日(%02d)} 1991/1/1 -> ~/Calendar/xy1999/xc199901.01" (if (boundp 'dos-machine-type) (format "%s/xy%d/xc%04d%02d.%02d" xcal-directory year year month day) (concat xcal-directory (if xcal-schedule-xcalndar-compatible "" (format "/xy%d" year)) (format "/xc%d%s%d" day (aref ["Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"] (1- month)) year)))) (defun xcal-write-region (begin end file) (xcal-make-directory (file-name-directory file)) (write-region (point-min) (point-max) file)) (defun xcal-make-directory (directory) "Make DIRECTORY recursively. gnus-make-directory そのまま" (let ((directory (expand-file-name directory default-directory))) (or (file-exists-p directory) (xcal-make-directory-1 "" directory)) )) (defun xcal-make-directory-1 (head tail) (cond ((string-match "^/\\([^/]+\\)" tail) (setq head (concat (file-name-as-directory head) (substring tail (match-beginning 1) (match-end 1)))) (or (file-exists-p head) (call-process "mkdir" nil nil nil head)) (xcal-make-directory-1 head (substring tail (match-end 1)))) ((string-equal tail "") t) )) (defun get-year-month-day () (let (date year month day) (setq date (current-time-string)) (string-match " \\([A-Z][a-z][a-z]\\) *\\([0-9]*\\) .* \\([0-9]*\\)$" date) (setq day (string-to-int (substring date (match-beginning 2) (match-end 2)))) (setq month (cdr (assoc (substring date (match-beginning 1) (match-end 1)) '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6) ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12))))) (setq year (string-to-int (substring date (match-beginning 3) (match-end 3)))) (list year month day))) (defun xcal-refresh () (let ((day xcal-current-day)) (xcal-1 xcal-month-offset) (goto-char (marker-position (aref xcal-day-markers day))) (setq xcal-current-day day))) (defun xcal-goto-day (day) (cond ((< day 1) (progn (xcal-1 (1- xcal-month-offset)) (setq xcal-current-day xcal-days) (goto-char (marker-position (aref xcal-day-markers xcal-days))))) ((<= day xcal-days) (progn (setq xcal-current-day day) (goto-char (marker-position (aref xcal-day-markers day))))) (t (xcal-1 (1+ xcal-month-offset)) (setq xcal-current-day 1) (goto-char (marker-position (aref xcal-day-markers 1))))) (xcal-show-keys)) (defun xcal-show-calendar-horizontal (&optional month-offset) (interactive "P") (if month-offset (setq month-offset (prefix-numeric-value month-offset))) (let* ((cur-win (selected-window)) (ymd (get-year-month-day)) (year (car ymd)) (month (car (cdr ymd))) (day (cond ((or (null month-offset)(= 0 month-offset)) (car (cdr (cdr ymd)))) (t nil))) (mini-calendar-window-width (if (featurep 'xemacs) (cond ((= 0 (specifier-instance scrollbar-width)) 23) (t 26)) (if (cdr (assoc 'vertical-scroll-bars default-frame-alist)) 25 24))) ) (setq TT:debug mini-calendar-window-width) (cond (month-offset (let ((year-month (+ (+ (* year 12) (- month 1)) month-offset))) (setq month (+ (% year-month 12) 1)) (setq year (/ year-month 12))))) (select-window (split-window-horizontally (- (window-width) mini-calendar-window-width))) (switch-to-buffer (set-buffer (get-buffer-create "*XCal-Calendar*"))) (setq buffer-read-only t) (let ((buffer-read-only nil)) (erase-buffer) (goto-char (point-min)) (if (= 1 month) (xcal-generate-month-1 12 (1- year) 0) (xcal-generate-month-1 (1- month) year 0)) (insert-string "\n\n") (xcal-generate-month-1 month year 0) (insert-string "\n\n") (if (= 12 month) (xcal-generate-month-1 1 (1+ year) 0) (xcal-generate-month-1 (1+ month) year 0)) (goto-line (/ (window-height) 2)) (select-window cur-win)))) (defun xcal-show-keys () (if (null xcal-keys-message) (setq xcal-keys-message (substitute-command-keys "\ 先月 \\[xcal-before] \ 次月 \\[xcal-next] \ 前日 \\[xcal-previous-day] \ 明日 \\[xcal-next-day] \ 編集 \\[xcal-edit-for-xcal] \ 削除 \\[xcal-delete-file] \ 終了 \\[xcal-quit]"))) (message xcal-keys-message)) (defun xcal-print-out () (interactive) (if (yes-or-no-p (format "%d 月のスケジュールを出力しますか ?" xcal-current-month)) (call-process-region (point-min) (point-max) (or xcal-print-out-command "lpr") nil nil))) (defvar xcal-week-select-index nil) ;; 1 2 3 4 5 ;; 1234567890123456789012345678901234567890123456789012 (defvar xcal-week-schedule '(("月" "xwMon") ("火" "xwTue") ("水" "xwWed") ("木" "xwThu") ("金" "xwFri") ("土" "xwSat") ("日" "xwSun"))) (setq xcal-select-minibuffer-map (make-keymap)) (suppress-keymap xcal-select-minibuffer-map) (define-key xcal-select-minibuffer-map "\C-p" 'xcal-week-select-prev) (define-key xcal-select-minibuffer-map "p" 'xcal-week-select-prev) (define-key xcal-select-minibuffer-map "P" 'xcal-week-select-prev) (define-key xcal-select-minibuffer-map "\C-b" 'xcal-week-select-prev) (define-key xcal-select-minibuffer-map "b" 'xcal-week-select-prev) (define-key xcal-select-minibuffer-map "B" 'xcal-week-select-prev) (define-key xcal-select-minibuffer-map "h" 'xcal-week-select-prev) (define-key xcal-select-minibuffer-map "H" 'xcal-week-select-prev) (define-key xcal-select-minibuffer-map "\C-n" 'xcal-week-select-next) (define-key xcal-select-minibuffer-map "n" 'xcal-week-select-next) (define-key xcal-select-minibuffer-map "N" 'xcal-week-select-next) (define-key xcal-select-minibuffer-map "\C-f" 'xcal-week-select-next) (define-key xcal-select-minibuffer-map "f" 'xcal-week-select-next) (define-key xcal-select-minibuffer-map "F" 'xcal-week-select-next) (define-key xcal-select-minibuffer-map "l" 'xcal-week-select-next) (define-key xcal-select-minibuffer-map "L" 'xcal-week-select-next) (define-key xcal-select-minibuffer-map "\C-m" '(lambda () (interactive) (setq xcal-selected t) (exit-minibuffer))) (define-key xcal-select-minibuffer-map "e" '(lambda () (interactive) (setq xcal-selected t) (exit-minibuffer))) (define-key xcal-select-minibuffer-map "E" '(lambda () (interactive) (setq xcal-selected t) (exit-minibuffer))) (define-key xcal-select-minibuffer-map "q" 'exit-minibuffer) (define-key xcal-select-minibuffer-map "Q" 'exit-minibuffer) (define-key xcal-select-minibuffer-map "\C-g" 'exit-minibuffer) (defun nop () (interactive)) (defun xcal-edit-for-xcal-week () (interactive) (let ((save-minibuffer-map minibuffer-local-map) inpt) (setq xcal-week-select-index 1) (setq unread-command-char ?p) ; 何かいい方法は？ (setq xcal-selected nil) (unwind-protect (progn (setq minibuffer-local-map xcal-select-minibuffer-map) (read-string "" "")) (setq minibuffer-local-map save-minibuffer-map)) (and xcal-selected (xcal-week-select-select)))) (defun xcal-week-select-prev () (interactive) (setq xcal-week-select-index (1- xcal-week-select-index)) (if (< xcal-week-select-index 0) (setq xcal-week-select-index (1- (length xcal-week-schedule)))) (xcal-disp-select-week)) (defun xcal-week-select-next () (interactive) (setq xcal-week-select-index (1+ xcal-week-select-index)) (if (<= (length xcal-week-schedule) xcal-week-select-index) (setq xcal-week-select-index 0)) (xcal-disp-select-week)) (defun xcal-disp-select-week () (let (p i) (erase-buffer) (insert "何曜日のスケジュールですか？ ") (setq i 0) (while (< i (length xcal-week-schedule)) (if (eq i xcal-week-select-index) (progn (setq p (point)) (insert (format "[%s]" (nth 0 (nth i xcal-week-schedule))))) (insert (format " %s " (nth 0 (nth i xcal-week-schedule))))) (setq i (1+ i))) (goto-char (1+ p)))) (defun xcal-week-select-select () (interactive) (set-buffer (get-buffer-create "*XCal Edit*")) (erase-buffer) (select-window (split-window-vertically (/ (window-height) 2))) (switch-to-buffer "*XCal Edit*") (xcal-edit-mode) (setq buffer-read-only nil) (set-buffer-modified-p (buffer-modified-p)) (setq mode-line-process (concat " " (nth 0 (nth xcal-week-select-index xcal-week-schedule)) "曜日のスケジュール")) (setq xcal-file (format "%s/%s" xcal-directory (nth 1 (nth xcal-week-select-index xcal-week-schedule)))) (and (file-exists-p xcal-file) (insert-file xcal-file)) (message (substitute-command-keys "Editing: Type \\[xcal-edit-cease-edit] to return to XCal, \\[xcal-edit-abort-edit] to abort."))) (copy-face 'default 'xcal-calendar-today-face) (defvar xcal-calendar-today-face 'xcal-calendar-today-face) (set-face-foreground 'xcal-calendar-today-face "black") (set-face-background 'xcal-calendar-today-face "gold") (defun xcal-generate-month-1 (month year indent) "calendarの今日の数字を反転させる。(93/09/06:isoyama)" (let* ((cur-win (selected-window)) (ymd (get-year-month-day)) (this-year (car ymd)) (this-month (car (cdr ymd))) (day (car (cdr (cdr ymd)))) (today-pos (xcal-generate-calendar-month month year indent day)) ) (if (and (= this-month month) (= this-year year)) (put-text-property (1- today-pos) (1+ today-pos) 'face xcal-calendar-today-face)))) (defun xcal-make-auto-holiday-alist (year) (list year (list 1 (xcal-day-of-seijin year)) (list 3 (xcal-day-of-syunbun year)) (list 9 (xcal-day-of-syuubun year)) (list 10 (xcal-day-of-taiiku year)))) (defun xcal-day-of-seijin (year) (cons (if (< year 2000) 15 (+ (mod (- 8 (calendar-day-of-week (list 1 1 year))) 7) 8)) "成人の日")) (defun xcal-day-of-syunbun (year) (cons (- (/ (+ (* 8 year) 1182) 33) (/ year 4)) "春分の日")) (defun xcal-day-of-syuubun (year) (cons (- (/ (+ (* 8 year) 1261) 33) (/ year 4)) "秋分の日")) (defun xcal-day-of-taiiku (year) (cons (if (< year 2000) 10 (+ (mod (- 8 (calendar-day-of-week (list 10 1 year))) 7) 8)) "体育の日")) (defun clength (str) (let ((idx 0)(width 0)) (while (< idx (length str)) (setq width (+ width (char-width (sref str idx)))) (setq idx (+ idx (char-bytes (sref str idx))))) width)) (defun xcal-lookup-face-create (face) (let ((facestr (symbol-name face))) (if window-system (if (car (member face (face-list))) face (progn (copy-face 'default face) (if (string-match "-underline" facestr) (progn (setq facestr (substring facestr 0 (match-beginning 0))) (set-face-underline-p face t))) (or (string= facestr "default") (set-face-foreground face facestr)) face)) (if (eq 'underline face) 'underline 'region)))) ;; ;; アラーム関係の関数 ;; (setq xcal-alarm-keymap (make-keymap)) (define-key xcal-alarm-keymap "q" '(lambda () (interactive) (kill-buffer (current-buffer)) (delete-frame))) (defun xcal-alarm-start--proc () (if (or (null xcal-alarm-proc) (not (eq (process-status xcal-alarm-proc) 'run))) (progn (or (file-exists-p xcal-alarm-prog) (error (format "xcal program [%s] not found." xcal-alarm-prog))) (setq xcal-alarm-proc (start-process "xcal-alarm" nil xcal-alarm-prog "-d" (expand-file-name xcal-directory) "-c" xcal-alarm-countdown "-u" xcal-alarm-update)) (setq xcal-alarm-all-ret "") (setq xcal-alarm-ret "") (set-process-filter xcal-alarm-proc 'xcal-alarm-filter) (set-process-sentinel xcal-alarm-proc 'xcal-alarm-sentinel-filter) (process-kill-without-query xcal-alarm-proc)))) (defun xcal-alarm-filter (process out) (setq xcal-alarm-all-ret (concat xcal-alarm-all-ret out)) (setq xcal-alarm-ret (concat xcal-alarm-ret out)) (if (string-match "^SOT\n" xcal-alarm-ret) (setq xcal-alarm-ret (substring xcal-alarm-ret (match-end 0)))) (if (string-match "^EOT\n" xcal-alarm-ret) (xcal-alarm-has-come (substring xcal-alarm-ret 0 (match-beginning 0)))) (setq xcal-alarm-ret "")) (defun xcal-alarm-sentinel-filter (process signal) (error (format "Process %s recived the msg %s" xcal-alarm-proc signal))) (defun xcal-alarm-has-come (msg) (let (buffer-read-only new frame buf) (setq new (not (get-buffer " *XCal alarm*"))) (setq buf (set-buffer (get-buffer-create " *XCal alarm*"))) (setq buffer-read-only nil) (erase-buffer) (insert "< Please type `q' for quit >") (put-text-property (point-min) (point-max) 'face 'region) (insert "\n") (insert msg) (setq buffer-read-only t) (use-local-map xcal-alarm-keymap) (if new (progn (setq frame (make-frame '((name . "Alarm") (height . 10) (width . 30)))) (set-window-buffer (frame-selected-window frame) buf))) (ding))) (provide 'xcal-19) ;; :-p (provide 'xcal-20)