mhc 1.0.0

data/emacs/mhc-parse.el

@@ -0,0 +1,286 @@
+;;; -*- mode: Emacs-Lisp; coding: utf-8 -*-
+
+;; Author:  Yoshinari Nomura <nom@quickhack.net>,
+;;          TSUCHIYA Masatoshi <tsuchiya@namazu.org>
+;; Created: 2000/04/30
+;; Revised: $Date$
+
+
+;;; Commentary:
+
+;; This file is a part of MHC, and includes functions to parse
+;; schedule headers.
+
+
+;;; Code:
+
+(require 'mhc-logic)
+(require 'mhc-record)
+(require 'mhc-header)
+
+(defvar mhc-parse/strict nil)
+
+(defun mhc-parse/continuous-lines ()
+  "ヘッダの継続行を処理して、内容のみを取り出す関数"
+  (let (list)
+    (skip-chars-forward " \t\n")
+    (while (not (eobp))
+      (setq list
+            (cons (buffer-substring-no-properties
+                   (point)
+                   (progn (end-of-line) (skip-chars-backward " \t") (point)))
+                  list))
+      (end-of-line)
+      (skip-chars-forward " \t\n"))
+    (mapconcat 'identity (nreverse list) " ")))
+
+(defun mhc-parse/day (record schedule)
+  (mhc-logic-parse-day (mhc-schedule-condition schedule))
+  schedule)
+
+(defun mhc-parse/cond (record schedule)
+  (mhc-logic-parse-cond (mhc-schedule-condition schedule))
+  schedule)
+
+(defun mhc-parse/duration (record schedule)
+  (mhc-logic-parse-duration (mhc-schedule-condition schedule))
+  schedule)
+
+(defun mhc-parse/priority (record schedule)
+  (if (looking-at mhc-logic/space-regexp)
+      (goto-char (match-end 0)))
+  (let ((content (buffer-substring
+                  (point)
+                  (progn (skip-chars-forward "0-9") (point)))))
+    (if (looking-at mhc-logic/space-regexp)
+        (goto-char (match-end 0)))
+    (if (eobp)
+        (mhc-schedule/set-priority schedule
+                                   (if (eq (length content) 0)
+                                       nil
+                                     (string-to-number content)))
+      (error "Parse ERROR !!!(at X-SC-Priority:)")))
+  schedule)
+
+(defun mhc-parse/subject (record schedule)
+  (mhc-schedule/set-subject
+   schedule
+   (mhc-eword-decode-string (mhc-parse/continuous-lines)))
+  schedule)
+
+(defun mhc-parse/location (record schedule)
+  (mhc-schedule/set-location
+   schedule
+   (mhc-eword-decode-string (mhc-parse/continuous-lines)))
+  schedule)
+
+(defconst mhc-parse/time-regexp "\\([012][0-9]\\):\\([0-5][0-9]\\)")
+
+(defun mhc-parse/time (record schedule)
+  (let ((time (mhc-parse/continuous-lines))
+        begin end)
+    (cond
+     ((string-match (concat "^" mhc-parse/time-regexp "-" mhc-parse/time-regexp "$") time)
+      (setq begin (+ (* 60 (string-to-number (match-string 1 time)))
+                     (string-to-number (match-string 2 time)))
+            end (+ (* 60 (string-to-number (match-string 3 time)))
+                   (string-to-number (match-string 4 time)))))
+     ((string-match (concat "^" mhc-parse/time-regexp "-?$") time)
+      (setq begin (+ (* 60 (string-to-number (match-string 1 time)))
+                     (string-to-number (match-string 2 time)))))
+     ((string-match (concat "^-" mhc-parse/time-regexp "$") time)
+      (setq end (+ (* 60 (string-to-number (match-string 1 time)))
+                   (string-to-number (match-string 2 time)))))
+     ((and mhc-parse/strict (not (string= "" time)))
+      (error "Parse ERROR!!!(at X-SC-Time:)")))
+    (mhc-schedule/set-time schedule begin end))
+  schedule)
+
+;; For backward compatibility.
+(defun mhc-parse/old-style-date (record schedule)
+  (mhc-logic-parse-old-style-date (mhc-schedule-condition schedule))
+  (mhc-parse/time record schedule))
+
+(defconst mhc-parse/alarm-regexp "^[0-9]+ \\(minute\\|hour\\|day\\)$")
+
+(defun mhc-parse/alarm (record schedule)
+  (let ((alarm (mhc-parse/continuous-lines)))
+    (unless (or (not mhc-parse/strict)
+                (string-match mhc-parse/alarm-regexp alarm)
+                (string= "" alarm))
+      (error "Parse ERROR!!! (at X-SC-Alarm:)"))
+    (mhc-schedule/set-alarm schedule alarm))
+  schedule)
+
+(defun mhc-parse/category (record schedule)
+  (let ((category (mhc-parse/continuous-lines)))
+    (mhc-schedule/set-categories
+     schedule
+     (nconc (delq nil
+                  (mapcar
+                   (lambda (str)
+                     (and (stringp str) (downcase str)))
+                   (mhc-misc-split
+                    (mhc-eword-decode-string category)
+                    "[ \t]+")))
+            (mhc-schedule-categories schedule))))
+  (mhc-logic/set-todo (mhc-schedule-condition schedule)
+                      (mhc-schedule-in-category-p schedule "todo"))
+  schedule)
+
+
+(defun mhc-parse/recurrence-tag (record schedule)
+  (mhc-schedule/set-recurrence-tag
+   schedule
+   (mhc-eword-decode-string (mhc-parse/continuous-lines)))
+  schedule)
+
+(defun mhc-parse/sequence (record schedule)
+  (if (looking-at mhc-logic/space-regexp)
+      (goto-char (match-end 0)))
+  (let ((content (buffer-substring
+                  (point)
+                  (progn (skip-chars-forward "0-9") (point)))))
+    (if (looking-at mhc-logic/space-regexp)
+        (goto-char (match-end 0)))
+    (if (eobp)
+        (mhc-schedule/set-sequence schedule
+                                   (if (eq (length content) 0)
+                                       nil
+                                     (string-to-number content)))
+      (error "Parse ERROR !!!(at X-SC-Sequence:)")))
+  schedule)
+
+;; FIXME: 要削除
+(defun mhc-parse/next (record schedule)
+  (let ((new (mhc-schedule-new record)))
+    (if schedule (mhc-schedule/set-region-end schedule (point-min)))
+    (mhc-schedule/set-region-start new (point-min))
+    new))
+
+;; FIXME: X-SC-Schedule の入れ子構造は、(mhc-db-add-exception-rule) の
+;; 実装の都合上受け入れられないので、top level 以外の X-SC-Schedule は
+;; 安全に無視される必要がある。
+(defun mhc-parse/schedule (record schedule)
+  (let ((buffer (current-buffer))
+        (start (point))
+        (end (point-max))
+        (schedule (mhc-schedule-new record)))
+    (mhc-schedule/set-region-start schedule start)
+    (mhc-schedule/set-region-start schedule end)
+    (with-temp-buffer
+      (insert-buffer-substring buffer start end)
+      (goto-char (point-min))
+      (while (not (eobp))
+        (let ((start (point)))
+          (if (skip-chars-forward " \t\n")
+              (delete-region start (point))))
+        (while (if (eobp)
+                   nil
+                 (eq ?\\ (progn (end-of-line) (preceding-char))))
+          (delete-char -1)
+          (forward-line))
+        (forward-line))
+      (goto-char (point-min))
+      (mhc-parse/internal-parser record schedule)))
+  schedule)
+
+;; FIXME: top level 以外の場所で記述された X-SC-Record-Id: は安全に無
+;; 視される必要があるが、現在の実装では何も考えずに上書きしてしまう。
+(defun mhc-parse/record-id (record schedule)
+  (mhc-record-set-id record (mhc-parse/continuous-lines))
+  schedule)
+
+;; FIXME: top level とそれ以外の場所で許される header が異なるので、
+;; multi pass parser に組み替えるべきかも知れない。
+(defun mhc-parse/internal-parser (record &optional schedule strict)
+  "Internal parseser of schedule headers in this narrowed buffer."
+  (let ((mhc-parse/strict strict)
+        (case-fold-search t)
+        func)
+    (while (not (eobp))
+      (if (looking-at "\\([^ \t:]+\\):")
+          (progn
+            (setq func (mhc-header-parse-function
+                        (format "%s" (match-string 1))))
+            (mhc-header-goto-end)
+            (if (fboundp func)
+                (save-restriction
+                  (narrow-to-region (match-beginning 0) (point))
+                  (goto-char (match-end 0))
+                  (setq schedule
+                        (funcall func
+                                 record
+                                 (or schedule
+                                     (if (memq func '(mhc-parse/schedule mhc-parse/next))
+                                         nil
+                                       (mhc-parse/next record nil)))))
+                  (goto-char (point-max)))))
+        ;; Always skip non-header lines.
+        (forward-line 1))))
+  schedule)
+
+(defun mhc-parse-buffer (&optional record strict)
+  "Parse schedule headers in this buffer."
+  (unless record
+    (setq record (mhc-record-new (buffer-file-name))))
+  (mhc-header-narrowing
+    (let ((schedule (mhc-parse/internal-parser record nil strict)))
+      (if schedule (mhc-schedule/set-region-end schedule (point)))))
+  ;; 得られた構造を整理する
+  (let (schedules sexp)
+    ;; 現れた順序に直しておく
+    (mhc-record-set-schedules record (nreverse (mhc-record-schedules record)))
+    ;; 先頭のスケジュールをデフォルトとして参照して、欠けている要素を埋めておく
+    (setq schedules (cdr (mhc-record-schedules record)))
+    (while schedules
+      (mhc-schedule-append-default (car schedules) (car (mhc-record-schedules record)))
+      (setq schedules (cdr schedules)))
+    ;; 各スケジュールの条件式を生成する
+    (mhc-logic-compile-file record))
+  record)
+
+(defun mhc-parse-file (filename)
+  "Parse schedules headers in the file, FILENAME."
+  (with-current-buffer
+      (mhc-get-buffer-create " *mhc-parse-file*")
+    (delete-region (point-min) (point-max))
+    (mhc-insert-file-contents-as-coding-system mhc-default-coding-system filename)
+    (mhc-parse-buffer (mhc-record-new filename))))
+
+
+
+(provide 'mhc-parse)
+
+;;; Copyright Notice:
+
+;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved.
+;; Copyright (C) 2000 MHC developing team. All rights reserved.
+
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 2. Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;; 3. Neither the name of the team nor the names of its contributors
+;;    may be used to endorse or promote products derived from this software
+;;    without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS''
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL
+;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+;; OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;; mhc-parse.el ends here.

data/emacs/mhc-process.el

@@ -0,0 +1,35 @@
+(defvar mhc-process nil)
+
+(add-to-list 'process-coding-system-alist '("^mhc$" . utf-8))
+
+(defun mhc-process-send-command (command)
+  (unless (and (processp mhc-process)
+               (eq (process-status mhc-process) 'run))
+    (mhc-start-process))
+  (message "COMMAND: %s" command)
+  (with-current-buffer (process-buffer mhc-process)
+    (delete-region (point-min) (point-max))
+    (process-send-string mhc-process (concat command "\n"))
+    (let ((i 1))
+      (while (not (and (> (point-max) 1)
+                       (eq (char-after (1- (point-max))) ?\n)))
+        (message (format "Waiting mhc process...%d" i))
+        (setq i (1+ i))
+        (accept-process-output mhc-process 0.5)))
+    (read (buffer-substring (point-min) (1- (point-max))))))
+
+(defun mhc-start-process ()
+  (interactive)
+  (let ((process-connection-type nil)) ;; use PIPE not tty
+    (if (and (processp mhc-process)
+             (eq (process-status mhc-process) 'run))
+        (kill-process mhc-process))
+    (setq mhc-process (start-process
+                       "mhc"
+                       (get-buffer-create " *mhc-scan-process*")
+                       "mhc"
+                       "server"))
+    (set-process-query-on-exit-flag mhc-process nil)
+    mhc-process))
+
+(provide 'mhc-process)

data/emacs/mhc-ps.el

@@ -0,0 +1,1174 @@
+;;; -*- mode: Emacs-Lisp; coding: utf-8 -*-
+
+;; Author:  TSUCHIYA Masatoshi <tsuchiya@namazu.org>
+;;          Hideyuki SHIRAI <shirai@quickhack.net>
+;; Created: 2000/06/18
+;; Revised: $Date: 2004/05/06 16:35:12 $
+
+
+;;; Commentary:
+
+;; This file is a part of MHC and includes functions to make
+;; PostScrpit calendar.
+
+
+;;; History:
+
+;; Original PostScript program was written
+;; by Patrick Wood <patwood@unirot.UUCP> in 1987.
+;;
+;; Shell stuff added by King Ables at Sep 3, 1987.
+;;
+;; Made pretty by tjt in 1988.
+;;
+;; Holiday and printer flag passing hacks added by
+;; smann@june.cs.washington.edu in Dec 1988.
+;;
+;; Used the better looking version with 5 rows of days rather than 6
+;; hacked together with holiday and banner/footnotes added
+;; by Joe Wood <jlw@lzga.ATT.COM> in Dec 1989.
+;;
+;; Fixed "-R" (didn't work at all; now it at least works on 8.5x11)
+;; and also fixed handling of unrecognized arguments
+;; by Jeff Mogul <mogul@decwrl.dec.com> in Jan 1990.
+;;
+;; Japanized and improved handling holidays
+;; by SUZUKI Shingo <ichimal@takopen.cs.uec.ac.jp> in Feb 2000.
+;;
+;; Stuffs rewritten with Emacs Lisp
+;; by TSUCHIYA Masatoshi <tsuchiya@namazu.org>
+;; in Jun 2000.
+
+
+;;; Bugs:
+
+;; This program doesn't work for months before 1753 (weird stuff
+;; happened in September, 1752).
+
+
+;;; Code:
+
+(require 'mhc)
+
+
+;;; Customize variables:
+
+(defcustom mhc-ps-preview-command "gv"
+  "*Command to preview PostScript calendar."
+  :group 'mhc
+  :type 'string)
+
+(defcustom mhc-ps-preview-command-arguments '()
+  "*Argument of previewer"
+  :group 'mhc
+  :type '(repeat string))
+
+(defcustom mhc-ps-print-command "lp"
+  "*Command to print PostScript calendar."
+  :group 'mhc
+  :type 'string)
+
+(defcustom mhc-ps-print-command-arguments '()
+  "*Argument of print command."
+  :group 'mhc
+  :type '(repeat string))
+
+(defcustom mhc-ps-paper-type t
+  "*Calendar paper type."
+  :group 'mhc
+  :type '(radio (const :tag "Landscape" t)
+                (const :tag "Portrait" nil)))
+
+(defcustom mhc-ps-paper-fill-print nil
+  "*Fill printing just in Landscape paper size."
+  :group 'mhc
+  :type 'boolean)
+
+(defcustom mhc-ps-truncate-lines nil
+  "*Truncate line."
+  :group 'mhc
+  :type 'boolean)
+
+(defcustom mhc-ps-left-margin 2
+  "*Left margin of the each schedule."
+  :group 'mhc
+  :type 'integer)
+
+(defcustom mhc-ps-string-width 20
+  "*Width of the each schedule."
+  :group 'mhc
+  :type 'integer)
+
+(defcustom mhc-ps-string-column 7
+  "*Column of the each schedule."
+  :group 'mhc
+  :type 'integer)
+
+(defcustom mhc-ps-title-font "Times-Bold"
+  "*PostScript Font used for title."
+  :group 'mhc
+  :type 'string)
+
+(defcustom mhc-ps-day-font "Helvetica-Bold"
+  "*PostScript Font used for days."
+  :group 'mhc
+  :type 'string)
+
+(defcustom mhc-ps-event-font "Times-Roman"
+  "*PostScript Font used for events."
+  :group 'mhc
+  :type 'string)
+
+(defcustom mhc-ps-japanese-font "Ryumin-Light-EUC-H"
+  "*PostScript Font used for Japanese characters."
+  :group 'mhc
+  :type 'string)
+
+(defcustom mhc-ps-coding-system
+  (if (boundp 'MULE) '*euc-japan*unix 'euc-japan-unix)
+  "*Coding system of PostScript data."
+  :group 'mhc
+  :type 'symbol)
+
+(defcustom mhc-ps-save-directory "~/"
+  "*Directory to save PostScript file."
+  :group 'mhc
+  :type 'directory)
+
+;;; Internal Variables:
+(defconst mhc-ps/string "\
+%!
+% PostScript program to draw calendar
+% Copyright \(C\) 1987 by Pipeline Associates, Inc.
+% Permission is granted to modify and distribute this free of charge.
+
+% The number after /month should be set to a number from 1 to 12.
+% The number after /year should be set to the year you want.
+% You can change the title and date fonts, if you want.
+% We figure out the rest.
+% This program won't produce valid calendars before 1800 due to the switch
+% from Julian to Gregorian calendars in September of 1752 wherever English
+% was spoken.
+
+%% For Japanese. Added by ichimal, 2000/2/6.
+%% Original code is generated by k2ps.
+/copyfont {     % font-dic extra-entry-count  copyfont  font-dic
+    1 index maxlength add dict begin
+    {
+        1 index /FID ne 2 index /UniqueID ne and
+        {def}{pop pop} ifelse
+    } forall
+    currentdict
+    end
+} bind def
+
+%% For Japanese. Added by ichimal, 2000/2/6.
+%% Original code is generated by k2ps.
+/narrowfont {   % ASCIIFontName EUCFontName  compositefont  font'
+    findfont dup /FontType get 0 eq {
+        12 dict begin
+        %
+        % 7+8 bit EUC font
+        %
+        12 dict begin
+        /EUCFont exch def
+        /FontInfo \(7+8 bit EUC font\) readonly def
+        /PaintType 0 def
+        /FontType 0 def
+        /FontMatrix matrix def
+        % /FontName
+        /Encoding \[
+            16#00 1 16#20 { pop 0 } for
+            16#21 1 16#28 { 16#20 sub } for
+            16#29 1 16#2F { pop 0 } for
+            16#30 1 16#74 { 16#27 sub } for
+            16#75 1 16#FF { pop 0 } for
+        \] def
+        /FMapType 2 def
+        EUCFont /WMode known
+        { EUCFont /WMode get /WMode exch def }
+        { /WMode 0 def } ifelse
+        /FDepVector \[
+            EUCFont /FDepVector get 0 get
+            \[ 16#21 1 16#28 {} for 16#30 1 16#74 {} for \]
+            {
+                13 dict begin
+                /EUCFont EUCFont def
+                /UpperByte exch 16#80 add def
+                % /FontName
+                /FontInfo \(EUC lower byte font\) readonly def
+                /PaintType 0 def
+                /FontType 3 def
+                /FontMatrix matrix def
+                /FontBBox {0 0 0 0} def
+                /Encoding \[
+                    16#00 1 16#A0 { pop /.notdef } for
+                    16#A1 1 16#FE { 16#80 sub 16 2 string cvrs
+                    \(cXX\) dup 1 4 -1 roll
+                    putinterval cvn } for
+                    /.notdef
+                \] def
+                % /UniqueID
+                % /WMode
+                /BuildChar {
+                    gsave
+                    exch dup /EUCFont get setfont
+                    /UpperByte get
+                    2 string
+                    dup 0 4 -1 roll put
+                    dup 1 4 -1 roll put
+                    dup stringwidth setcharwidth
+                    0 0 moveto show
+                    grestore
+                } bind def
+                currentdict
+                end
+                /lowerbytefont exch definefont
+           } forall
+        \] def
+        currentdict
+        end
+        /eucfont exch definefont
+        exch
+        findfont 1 copyfont dup begin
+            /FontMatrix FontMatrix \[.83 0 0 1 0 0.05\] matrix concatmatrix def
+        end
+        /asciifont exch definefont
+        exch
+        /FDepVector \[ 4 2 roll \] def
+        /FontType 0 def
+        /WMode 0 def
+        /FMapType 4 def
+        /FontMatrix matrix def
+        /Encoding \[0 1\] def
+        /FontBBox {0 0 0 0} def
+        currentdict
+        end
+    }{
+        pop findfont 0 copyfont
+    } ifelse
+} def
+
+/month @MONTH@ def
+/year @YEAR@ def
+/titlefont /@TFONT@ def
+/dayfont /@DFONT@ def
+%% For Japanese. Changed by ichimal, 2000/2/6.
+%% Original code is generated by k2ps.
+%% /eventfont /@EFONT@ def
+/Courier-Ryumin
+    /@EFONT@ /@JFONT@ narrowfont definefont pop
+/eventfont /Courier-Ryumin def
+
+/holidays \[ @HOLIDAYS@ \] def
+/lholidays \[ @LHOLIDAYS@ \] def
+/nholidays \[ @NHOLIDAYS@ \] def
+/schedules \[ @SCHEDULES@ \] def
+/lschedules \[ @LSCHEDULES@ \] def
+/nschedules \[ @NSCHEDULES@ \] def
+/Bannerstring \(@BANNER@\) def
+/Lfootstring \(@LFOOT@\) def
+/Rfootstring \(@RFOOT@\) def
+/Cfootstring \(@CFOOT@\) def
+
+% calendar names - change these if you don't speak english
+% \"August\", \"April\" and \"February\" could stand to be kerned even if you do
+
+/month_names
+    \[ \(January\) \(February\) \(March\) \(April\) \(May\) \(June\) \(July\)
+    \(August\) \(September\) \(October\) \(November\) \(December\) \]
+def
+
+/day_names
+    \[ \(Sunday\) \(Monday\) \(Tuesday\) \(Wednesday\) \(Thursday\) \(Friday\) \(Saturday\) \]
+def
+
+% layout parameters - you can change these, but things may not look nice
+
+/daywidth 100 def
+/dayheight 95 def
+
+/titlefontsize 48 def
+/weekdayfontsize 10 def
+/datefontsize 24 def
+/footfontsize 20 def
+
+/topgridmarg 35 def
+/leftmarg 35 def
+/daytopmarg 14 def
+/dayleftmarg 5 def
+
+% layout constants - don't change these, things probably won't work
+
+/mainrows @WEEKS@ def
+/subrows 6 def
+
+% calendar constants - change these if you want a French revolutionary calendar
+
+/days_week 7 def
+
+/days_month \[ 31 28 31 30 31 30 31 31 30 31 30 31 \] def
+
+/isleap {               % is this a leap year?
+    year 4 mod 0 eq         % multiple of 4
+    year 100 mod 0 ne       % not century
+    year 1000 mod 0 eq or and   % unless it's a millenia
+} def
+
+/ndays {                % number of days in this month
+    days_month month 1 sub get
+    month 2 eq          % February
+    isleap and
+    {
+        1 add
+    } if
+} def
+
+/weekday {              % weekday \(range 0-6\) for integer date
+    days_week mod
+} def
+
+/startday {             % starting day-of-week for this month
+    /off year 2032 sub def      % offset from start of \"epoch\"
+    off
+    off 4 idiv add          % number of leap years
+    off 100 idiv sub        % number of centuries
+    off 1000 idiv add       % number of millenia
+    4 add weekday days_week add     % offset from Jan 1 2032
+    /off exch def
+    1 1 month 1 sub {
+        /idx exch def
+        days_month idx 1 sub get
+        idx 2 eq
+        isleap and
+        {
+            1 add
+        } if
+        /off exch off add def
+    } for
+    off weekday         % 0--Sunday, 1--monday, etc.
+} def
+
+/prtevent {     % event-string day prtevent
+                %  print out an event
+    /start startday def
+    /day 2 1 roll def
+    day start add 1 sub 7 mod daywidth mul
+    day start add 1 sub 7 div truncate dayheight neg mul
+    -5
+    numevents day start add get -10 mul add
+    numevents
+    day start add
+    numevents day start add get 1 add
+    put
+    add 2 add moveto
+    show
+} def
+
+/drawevents {       % read in a file full of events; print
+                    %  the events for this month
+    /numevents
+        \[0 0 0 0 0 0 0
+          0 0 0 0 0 0 0
+          0 0 0 0 0 0 0
+          0 0 0 0 0 0 0
+          0 0 0 0 0 0 0
+          0 0 0 0 0 0 0
+          0 0 0 0 0 0 0\] def
+    eventfont findfont 9 scalefont setfont
+    0 2 holidays length 2 sub { % for the \"Holidays\"
+        dup
+        1 add holidays 2 1 roll get
+        2 1 roll holidays 2 1 roll get
+        prtevent
+    } for
+    0 2 schedules length 2 sub { % for the \"Schedules\"
+        dup
+        1 add schedules 2 1 roll get
+        2 1 roll schedules 2 1 roll get
+        prtevent
+    } for
+} def
+
+% ------------------------------------------------------------------------
+
+/prtnum { 3 string cvs show } def
+
+/center {               % center string in given width
+    /width exch def
+    /str exch def width str
+    stringwidth pop sub 2 div 0 rmoveto str show
+} def
+
+/centernum { exch 3 string cvs exch center } def
+
+/drawgrid {             % draw calendar boxes
+    titlefont findfont weekdayfontsize scalefont setfont
+    currentpoint /y0 exch def /x0 exch def
+    0 1 days_week 1 sub {
+        submonth 0 eq
+        {
+            x0 y0 moveto
+            dup dup daywidth mul 40 rmoveto
+            day_names exch get
+            daywidth center
+        } if
+        x0 y0 moveto
+        daywidth mul topgridmarg rmoveto
+        1.0 setlinewidth
+        submonth 0 eq
+        {
+            /rowsused mainrows 1 sub def
+        }
+        {
+            /rowsused subrows 1 sub def
+        }
+        ifelse
+        0 1 rowsused {
+            gsave
+            daywidth 0 rlineto
+            0 dayheight neg rlineto
+            daywidth neg 0 rlineto
+            closepath stroke
+            grestore
+            0 dayheight neg rmoveto
+        } for
+    } for
+} def
+
+/drawnums {             % place day numbers on calendar
+    dayfont findfont datefontsize
+    submonth 0 ne
+    {
+        2.5 mul
+    } if scalefont setfont
+    /start startday def
+    /days ndays def
+    start daywidth mul dayleftmarg add daytopmarg rmoveto
+    submonth 0 ne
+    {
+        dayleftmarg neg dayheight -2 div rmoveto
+    } if
+    1 1 days {
+        /day exch def
+        gsave
+        day start add weekday 0 eq
+        {
+            submonth 0 eq {
+                .7 setgray
+            }
+            {
+                holidaymark
+            } ifelse
+        } if
+        day start add weekday 1 eq
+        {
+            submonth 0 eq {
+                .7 setgray
+            }
+            {
+                holidaymark
+            } ifelse
+        } if
+        %% Added by ichimal, 2000.2
+        submonth 0 eq {
+            0 2 holidays length 2 sub {
+                holidays 2 1 roll get day eq {
+                    .7 setgray
+                    exit
+                } if
+            } for
+        }
+        {
+            nsubmonth 0 eq {
+                0 1 lholidays length 1 sub {
+                    lholidays exch get day eq {
+                        holidaymark
+                        exit
+                    } if
+                } for
+                0 1 lschedules length 1 sub {
+                    lschedules exch get day eq {
+                        shedulemark
+                        exit
+                    } if
+                } for
+            }
+            {
+                0 1 nholidays length 1 sub {
+                    nholidays exch get day eq {
+                        holidaymark
+                        exit
+                    } if
+                } for
+                0 1 nschedules length 1 sub {
+                    nschedules exch get day eq {
+                        shedulemark
+                        exit
+                    } if
+                } for
+            } ifelse
+        } ifelse
+        submonth 0 eq
+        {
+            day prtnum
+        }
+        {
+            day daywidth centernum
+        } ifelse
+        grestore
+        day start add weekday 0 eq
+        {
+            currentpoint exch pop dayheight sub 0 exch moveto
+            submonth 0 eq
+            {
+                dayleftmarg 0 rmoveto
+            } if
+        }
+        {
+            daywidth 0 rmoveto
+        } ifelse
+    } for
+} def
+
+/holidaymark {               % tiny holiday mark
+    gsave
+    0 dayheight 2 div daytopmarg add 5 add rmoveto
+    daywidth 0 rlineto
+    0 dayheight neg rlineto
+    daywidth neg 0 rlineto
+    .9 setgray
+    closepath fill
+    grestore
+} def
+
+/shedulemark {               % tiny shedule mark
+    gsave
+    80 60 rmoveto
+    10 0 rlineto  0 -10 rlineto
+    -10 0 rlineto 0 10 rlineto
+    closepath
+    .0 setgray fill
+    grestore
+} def
+
+/drawfill {             % place fill squares on calendar
+    /start startday def
+    /days ndays def
+    currentpoint /y0 exch def /x0 exch def
+    submonth 0 eq
+    {
+        usefirst
+        {
+            /fillstart 2 def
+        }
+        {
+            /fillstart 0 def
+        }
+        ifelse
+    }
+    {
+        /fillstart 0 def
+    }
+    ifelse
+    fillstart daywidth mul topgridmarg rmoveto
+    1.0 setlinewidth
+    fillstart 1 start 1 sub {
+        gsave
+        .9 setgray
+        daywidth 0 rlineto
+        0 dayheight neg rlineto
+        daywidth neg 0 rlineto
+        closepath fill
+        grestore
+        daywidth 0 rmoveto
+    } for
+    x0 y0 moveto
+    submonth 0 ne
+    {
+        /lastday subrows days_week mul def
+        days_week 1 sub daywidth mul -440 rmoveto
+    }
+    {
+        /lastday mainrows days_week mul 2 sub fillstart add def
+        days_week 3 sub fillstart add daywidth mul
+        @FOFFSET@ dayheight add rmoveto
+    } ifelse
+    lastday -1 ndays start 1 add add
+    {
+        /day exch def
+        gsave
+        .9 setgray
+        daywidth 0 rlineto
+        0 dayheight neg rlineto
+        daywidth neg 0 rlineto
+        closepath fill
+        grestore
+        day weekday 1 eq
+        {
+            submonth 0 ne
+            {
+                x0 y0 moveto
+                days_week 1 sub daywidth mul
+                -440 dayheight add rmoveto
+            }
+            {
+                x0 y0 moveto
+                days_week 1 sub daywidth mul
+                @FOFFSET@ dayheight add rmoveto
+            } ifelse
+        }
+        {
+            daywidth neg 0 rmoveto
+        } ifelse
+    } for
+} def
+
+/usefirst {             % are last two boxes used by days?
+    start ndays add mainrows days_week mul 3 sub gt
+    start 2 ge and
+    mainrows 6 eq or
+} def
+
+/calendar
+{
+    titlefont findfont titlefontsize scalefont setfont
+    0 60 moveto
+    /month_name month_names month 1 sub get def
+    month_name show
+    /yearstring year 10 string cvs def
+    daywidth days_week mul yearstring stringwidth pop sub 60 moveto
+    yearstring show
+
+    eventflag {
+        % Show a centered Banner if any at the Top
+        daywidth days_week mul 2 div
+        Bannerstring stringwidth pop 2 div sub
+        60 moveto
+        Bannerstring show
+        % Show footnotes left-center-right
+        eventfont findfont footfontsize scalefont setfont
+        /bottomrow { dayheight mainrows mul 5 sub neg } def
+        0 bottomrow moveto
+        Lfootstring show
+        daywidth days_week mul Rfootstring stringwidth pop sub
+        bottomrow moveto
+        Rfootstring show
+        daywidth days_week mul Cfootstring stringwidth pop sub 2 div
+        bottomrow moveto
+        Cfootstring show
+
+    } if
+
+    0 -5 moveto
+    drawnums
+
+    0 -5 moveto
+    drawfill
+
+    eventflag {
+        0 0 moveto
+        drawevents
+    } if
+
+    0 -5 moveto
+    drawgrid
+} def
+
+/eventflag true def
+
+@SCALE@ scale
+@ROTATE@ rotate
+@TRANSLATE@ translate
+/submonth 0 def
+calendar
+/eventflag false def
+month 1 sub 0 eq
+{
+    /lmonth 12 def
+    /lyear year 1 sub def
+}
+{
+    /lmonth month 1 sub def
+    /lyear year def
+} ifelse
+month 1 add 13 eq
+{
+    /nmonth 1 def
+    /nyear year 1 add def
+}
+{
+    /nmonth month 1 add def
+    /nyear year def
+} ifelse
+usefirst
+{
+    0 30 translate
+}
+{
+    days_week 2 sub daywidth mul -350 translate
+}
+ifelse
+/submonth 1 def
+/nsubmonth 0 def
+/year lyear def
+/month lmonth def
+gsave
+.138 .138 scale
+12 -120 translate
+calendar
+grestore
+/submonth 1 def
+/nsubmonth 1 def
+/year nyear def
+/month nmonth def
+daywidth 0 translate
+gsave
+.138 .138 scale
+12 -120 translate
+calendar
+grestore
+
+showpage
+")
+
+(defconst mhc-ps/replace-table
+  '(("@MONTH@"     . (format "%d" month))
+    ("@YEAR@"      . (format "%d" year))
+    ("@TFONT@"     . mhc-ps-title-font)
+    ("@DFONT@"     . mhc-ps-day-font)
+    ("@EFONT@"     . mhc-ps-event-font)
+    ("@JFONT@"     . mhc-ps-japanese-font)
+    ("@HOLIDAYS@"  . holidays-buffer)
+    ("@SCHEDULES@" . schedules-buffer)
+    ("@LHOLIDAYS@" . last-holidays-buffer)
+    ("@LSCHEDULES@" . last-schedules-buffer)
+    ("@NHOLIDAYS@" . next-holidays-buffer)
+    ("@NSCHEDULES@" . next-schedules-buffer)
+    ("@WEEKS@"     . (number-to-string weeks))
+    ("@FOFFSET@"   . (if (eq weeks 6) "-535" "-440"))
+    ("@BANNER@"    . (user-login-name))
+    ("@LFOOT@"     . "")
+    ("@RFOOT@"     . "")
+    ("@CFOOT@"     . "")
+    ("@SCALE@"     . (cond
+                      ((and mhc-ps-paper-type
+                            (or (not mhc-ps-paper-fill-print)
+                                (eq weeks 6)))
+                       "0.85 0.85")
+                      (mhc-ps-paper-type "1.0 1.0")
+                      (t "0.75 0.75")))
+    ("@ROTATE@"    . (if mhc-ps-paper-type "90" "0"))
+    ("@TRANSLATE@" . (cond
+                      ((and mhc-ps-paper-type
+                            (or (not mhc-ps-paper-fill-print)
+                                (eq weeks 6)))
+                       "140 -120")
+                      (mhc-ps-paper-type "50 -120")
+                      (t "50 900")))))
+
+(defun mhc-ps/weeks (date)
+  (if (> (+ (mhc-date-dd (mhc-date-mm-last date))
+            (mhc-date-ww (mhc-date-mm-first date)))
+         35) 6 5))
+
+(defun mhc-ps/substring (str width)
+  (let ((clist (mhc-string-to-char-list str))
+        cw (i 0) (w 0) (ow 0) (spc ?\ ))
+    (catch 'loop
+      (while clist
+        (setq w (+ w (char-width (car clist))))
+        (if (> w width) (throw 'loop nil))
+        (setq i (+ i (length (char-to-string (car clist)))))
+        (setq clist (cdr clist))))
+    (substring str 0 i)))
+
+(defun mhc-ps/compose-subject (time subject margin)
+  (let ((mstr (make-string margin ?\ ))
+        pos str)
+    ;; Delete characters to emphasize subject.
+    (and (string-match "^\\*+[ \t\r\f\n]*" subject)
+         (setq pos (match-end 0))
+         (string-match "[ \t\r\f\n]*\\*+$" subject)
+         (setq subject (substring subject pos (match-beginning 0))))
+    (if time
+        (setq str (concat time " " subject))
+      (setq str subject))
+    (cond
+     ((<= (string-width str) mhc-ps-string-width)
+      (list str))
+     (mhc-ps-truncate-lines
+      (if (null time)
+          (list
+           (if (= (string-width
+                   (setq subject (mhc-ps/substring subject mhc-ps-string-width)))
+                  mhc-ps-string-width)
+               (concat subject "$")
+             subject))
+        (setq subject (concat mstr subject))
+        (if (= (string-width
+                (setq subject (mhc-ps/substring subject mhc-ps-string-width)))
+               mhc-ps-string-width)
+            (setq subject (concat subject "$")))
+        (list time subject)))
+     (t
+      (with-temp-buffer
+        (let ((fill-column mhc-ps-string-width)
+              (left-margin 0)
+              ret)
+          (insert str)
+          (fill-region (point-min) (point-max))
+          (goto-char (point-min))
+          (if (= (forward-line 1) 0)
+              (let ((fill-column (- mhc-ps-string-width margin)))
+                (fill-region (point) (point-max))))
+          (delete-region (goto-char (point-max))
+                         (progn (skip-chars-backward " \t\n") (point)))
+          (goto-char (point-min))
+          (setq ret (list (buffer-substring
+                           (point) (progn (end-of-line) (point)))))
+          (forward-line 1)
+          (while (not (eobp))
+            (setq ret (cons
+                       (concat
+                        mstr
+                        (buffer-substring
+                         (point) (progn (end-of-line) (point))))
+                       ret))
+            (forward-line 1))
+          (nreverse ret)))))))
+
+(defun mhc-ps/encode-string (string)
+  (let ((start 0) buf ch)
+    (while (string-match "[()\\\\]" string start)
+      (setq ch (aref string (match-beginning 0))
+            buf (cons (if (eq ch ?\() "\\("
+                        (if (eq ch ?\)) "\\)"
+                          "\\\\"))
+                      (cons (substring string start (match-beginning 0)) buf))
+            start (match-end 0)))
+    (eval (cons 'concat (nreverse (cons (substring string start) buf))))))
+
+
+(defun mhc-ps/schedule-to-string (dayinfo schedule)
+  (let ((begin (mhc-schedule-time-begin schedule))
+        (end (mhc-schedule-time-end schedule))
+        (day (mhc-day-day-of-month dayinfo)))
+    (if (or begin end)
+        (mapconcat (lambda (str)
+                     (format "%d ( %s)" day (mhc-ps/encode-string str)))
+                   (mhc-ps/compose-subject
+                    (concat
+                     (if begin (mhc-time-to-string begin) "")
+                     (if end (concat "-" (mhc-time-to-string end)) ""))
+                    (mhc-schedule-subject-as-string schedule)
+                    mhc-ps-left-margin)
+                   " ")
+      (mapconcat (lambda (str)
+                   (format "%d ( %s)" day (mhc-ps/encode-string str)))
+                 (mhc-ps/compose-subject
+                  nil
+                  (mhc-schedule-subject-as-string schedule) mhc-ps-left-margin)
+                 " "))))
+
+
+(defun mhc-ps/uniq-list (lst)
+  (let ((tmp lst))
+    (while tmp (setq tmp (setcdr tmp (delete (car tmp) (cdr tmp))))))
+  lst)
+
+
+(defun mhc-ps/make-contents (file year month &optional category-predicate)
+  (let ((weeks (mhc-ps/weeks (mhc-date-new year month 1)))
+        (last-yymm (mhc-date-mm-- (mhc-date-new year month 1)))
+        (next-yymm (mhc-date-mm++ (mhc-date-new year month 1)))
+        schedules-buffer holidays-buffer
+        last-schedules-buffer last-holidays-buffer
+        next-schedules-buffer next-holidays-buffer)
+    ;; this month
+    (let ((dayinfo-list (mhc-db-scan-month year month)))
+      (while dayinfo-list
+        (let ((schedules (mhc-day-schedules (car dayinfo-list))))
+          (while schedules
+            (when (funcall category-predicate (car schedules))
+              (if (mhc-schedule-in-category-p (car schedules) "holiday")
+                  (setq holidays-buffer
+                        (cons (mhc-ps/schedule-to-string
+                               (car dayinfo-list) (car schedules))
+                              holidays-buffer))
+                (setq schedules-buffer
+                      (cons (mhc-ps/schedule-to-string
+                             (car dayinfo-list) (car schedules))
+                            schedules-buffer))))
+            (setq schedules (cdr schedules))))
+        (setq dayinfo-list (cdr dayinfo-list))))
+    ;; last month
+    (let ((dayinfo-list (mhc-date-let last-yymm (mhc-db-scan-month yy mm))))
+      (while dayinfo-list
+        (let ((schedules (mhc-day-schedules (car dayinfo-list))))
+          (while schedules
+            (when (funcall category-predicate (car schedules))
+              (if (mhc-schedule-in-category-p (car schedules) "holiday")
+                  (setq last-holidays-buffer
+                        (cons (number-to-string
+                               (mhc-day-day-of-month (car dayinfo-list)))
+                              last-holidays-buffer))
+                (setq last-schedules-buffer
+                      (cons (number-to-string(mhc-day-day-of-month (car dayinfo-list)))
+                            last-schedules-buffer))))
+            (setq schedules (cdr schedules))))
+        (setq dayinfo-list (cdr dayinfo-list))))
+    ;; next month
+    (let ((dayinfo-list (mhc-date-let next-yymm (mhc-db-scan-month yy mm))))
+      (while dayinfo-list
+        (let ((schedules (mhc-day-schedules (car dayinfo-list))))
+          (while schedules
+            (when (funcall category-predicate (car schedules))
+              (if (mhc-schedule-in-category-p (car schedules) "holiday")
+                  (setq next-holidays-buffer
+                        (cons (number-to-string
+                               (mhc-day-day-of-month (car dayinfo-list)))
+                              next-holidays-buffer))
+                (setq next-schedules-buffer
+                      (cons (number-to-string
+                             (mhc-day-day-of-month (car dayinfo-list)))
+                            next-schedules-buffer))))
+            (setq schedules (cdr schedules))))
+        (setq dayinfo-list (cdr dayinfo-list))))
+    (setq last-schedules-buffer (mhc-ps/uniq-list last-schedules-buffer)
+          last-holidays-buffer (mhc-ps/uniq-list last-holidays-buffer)
+          next-schedules-buffer (mhc-ps/uniq-list next-schedules-buffer)
+          next-holidays-buffer (mhc-ps/uniq-list next-holidays-buffer))
+    (setq schedules-buffer
+          (mapconcat 'identity (nreverse schedules-buffer) " ")
+          holidays-buffer
+          (mapconcat 'identity (nreverse holidays-buffer) " ")
+          last-schedules-buffer
+          (mapconcat 'identity (nreverse last-schedules-buffer) " ")
+          last-holidays-buffer
+          (mapconcat 'identity (nreverse last-holidays-buffer) " ")
+          next-schedules-buffer
+          (mapconcat 'identity (nreverse next-schedules-buffer) " ")
+          next-holidays-buffer
+          (mapconcat 'identity (nreverse next-holidays-buffer) " "))
+    (with-temp-buffer
+      (insert mhc-ps/string)
+      (let ((case-fold-search nil)
+            (alist mhc-ps/replace-table)
+            key value)
+        (while alist
+          (setq key   (car (car alist))
+                value (eval (cdr (car alist)))
+                alist (cdr alist))
+          (goto-char (point-min))
+          (while (search-forward key nil t)
+            (delete-region (- (point) (length key)) (point))
+            (insert value))))
+      (and file
+          (mhc-write-region-as-coding-system
+           mhc-ps-coding-system (point-min) (point-max) (expand-file-name file)
+           nil 'nomsg))
+      (buffer-substring (point-min) (point-max)))))
+
+(defvar mhc-ps/process-file-alist '())
+
+(defun mhc-ps/process (command arguments file buffer year month
+                               category-predicate)
+  (mhc-setup)
+  (message "PostScript creating...")
+  (let ((contents
+         (mhc-ps/make-contents file year month category-predicate)))
+    (if (null contents)
+        (message "No PostScript create.")
+      (cond
+       ((stringp command)
+        (let ((process
+               (apply (function start-process)
+                      (format "mhc-ps-%s" command)
+                      (mhc-get-buffer-create (format " *mhc-ps-%s*" command))
+                      command (append arguments (list (expand-file-name file))))))
+          (set-process-coding-system
+           process mhc-ps-coding-system mhc-ps-coding-system)
+          (set-process-sentinel process 'mhc-ps/process-sentinel)
+          (setq mhc-ps/process-file-alist
+                (cons (cons process (expand-file-name file))
+                      mhc-ps/process-file-alist))
+          (message "PostScript creating...done")))
+       ((eq command 'save)
+        (message "PostScript saving (%s)...done" file))
+       ((eq command 'buffer)
+        (pop-to-buffer (get-buffer-create buffer))
+        (kill-new contents)
+        (let ((msg "Insert PostScript data ? (y or n) ")
+              (char nil))
+          (message msg)
+          (while (null char)
+            (setq char (read-char-exclusive))
+            (if (or (eq ?y char) (eq ?\  char)
+                    (eq ?n char) (eq ?\177 char))
+                ()
+              (setq char nil)
+              (message (concat "Please answer y or n. " msg))))
+          (if (or (eq ?y char) (eq ?\  char))
+              (save-excursion
+                (insert contents)
+                (message "PostScript insert to \"%s\"." buffer))
+            (message "PostScript data to the latest kill in the kill ring."))))))))
+
+
+(defun mhc-ps/process-sentinel (process event)
+  (let ((al (assoc process mhc-ps/process-file-alist)))
+    (and (cdr al) (file-writable-p (cdr al)) (delete-file (cdr al)))
+    (setq mhc-ps/process-file-alist
+          (delete al mhc-ps/process-file-alist))))
+
+;;;###autoload
+(defun mhc-ps (&optional arg)
+  "*Create PostScript calendar with selected method."
+  (interactive "P")
+  (let ((method 'preview)
+        (date (or (mhc-current-date-month) (mhc-calendar-get-date)))
+        year month char)
+    (if (or arg (null date))
+        (setq date (mhc-input-month "Month: " date)))
+    (setq year (mhc-date-yy date))
+    (setq month (mhc-date-mm date))
+    (message "pre(V)iew (default), (P)rint, (S)ave, (I)nsert buffer")
+    (condition-case nil
+        (setq char (read-char))
+      (error (setq char ?v)))
+    (cond
+     ((memq char '(?p ?P))
+      (mhc-ps-print year month mhc-default-category-predicate-sexp))
+     ((memq char '(?s ?S))
+      (mhc-ps-save
+       year month
+       (expand-file-name
+        (mhc-date-format date "mhc%04d%02d.ps" yy mm)
+        mhc-ps-save-directory)
+       mhc-default-category-predicate-sexp))
+     ((memq char '(?i ?I))
+      (mhc-ps-insert-buffer
+       year month
+       (read-buffer "Insert buffer: " "*mhc-postscript*")
+       mhc-default-category-predicate-sexp))
+     (t
+      (mhc-ps-preview year month mhc-default-category-predicate-sexp)))))
+
+
+;;;###autoload
+(defun mhc-ps-preview (year month &optional category-predicate)
+  "*Preview PostScript calendar."
+  (interactive
+   (let* ((cdate (or (mhc-current-date-month) (mhc-calendar-get-date)))
+          (date (mhc-input-month "Month: " cdate)))
+     (list
+      (mhc-date-yy date)
+      (mhc-date-mm date)
+      mhc-default-category-predicate-sexp)))
+  (mhc-ps/process mhc-ps-preview-command mhc-ps-preview-command-arguments
+                  (expand-file-name
+                   (format "mhc%04d%02d.ps" year month)
+                   mhc-ps-save-directory)
+                  nil
+                  year month
+                  category-predicate))
+
+;;;###autoload
+(defun mhc-ps-print (year month &optional category-predicate)
+  "*Print PostScript calendar."
+  (interactive
+   (let* ((cdate (or (mhc-current-date-month) (mhc-calendar-get-date)))
+          (date (mhc-input-month "Month: " cdate)))
+     (list
+      (mhc-date-yy date)
+      (mhc-date-mm date)
+      mhc-default-category-predicate-sexp)))
+  (mhc-ps/process mhc-ps-print-command mhc-ps-print-command-arguments
+                  (expand-file-name
+                   (format "mhc%04d%02d.ps" year month)
+                   mhc-ps-save-directory)
+                  nil
+                  year month
+                  category-predicate))
+
+;;;###autoload
+(defun mhc-ps-save (year month file &optional category-predicate)
+  "*Save PostScript calendar."
+  (interactive
+   (let* ((cdate (or (mhc-current-date-month) (mhc-calendar-get-date)))
+          (date (mhc-input-month "Month: " cdate))
+          (default (expand-file-name
+                    (mhc-date-format date "mhc%04d%02d.ps" yy mm)
+                    mhc-ps-save-directory))
+          (file (read-file-name "Save file: " default default)))
+     (list
+      (mhc-date-yy date)
+      (mhc-date-mm date)
+      file
+      mhc-default-category-predicate-sexp)))
+  (mhc-ps/process 'save nil
+                  file nil
+                  year month
+                  category-predicate))
+
+;;;###autoload
+(defun mhc-ps-insert-buffer (year month buffer &optional category-predicate)
+  "*Insert PostScript calendar."
+  (interactive
+   (let* ((cdate (or (mhc-current-date-month) (mhc-calendar-get-date)))
+          (date (mhc-input-month "Month: " cdate))
+          (buffer (read-buffer "Insert buffer: " "*mhc-postscript*")))
+     (list
+      (mhc-date-yy date)
+      (mhc-date-mm date)
+      buffer
+      mhc-default-category-predicate-sexp)))
+  (mhc-ps/process 'buffer nil
+                  nil buffer
+                  year month
+                  category-predicate))
+
+
+(provide 'mhc-ps)
+
+
+;;; Copyright Notice of the PostScript programs.
+
+;; Copyright (C) 1987 by Pipeline Associates, Inc.
+;; Copyright (C) 2000 by SUZUKI Shingo <ichimal@takopen.cs.uec.ac.jp>.
+
+;; Permission is granted to modify and distribute this free of charge.
+
+
+;;; Copyright Notice of the Emacs Lisp programs.
+
+;; Copyright (C) 2000 MHC developing team. All rights reserved.
+
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 2. Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;; 3. Neither the name of the team nor the names of its contributors
+;;    may be used to endorse or promote products derived from this software
+;;    without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS''
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL
+;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+;; OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;; mhc-ps.el ends here.