LISPでオブジェクト指向プログラミングのサンプル

LISPでオブジェクト指向プログラミング（クラス定義とか）をしたことがほとんどなかったので，下記問題解答を記述してみたものを，サンプルと備忘録を兼ねて掲載．元はC++の構造体を用いる問題なので，継承も集約もMOPもないけど．

• APG4b：EX24 - 時計の実装

入力例（上2行，時刻と変更秒数）と出力例（下2行，変更前と変更後）を抜粋．

0 0 0
90
00:00:00
00:01:30

0 0 0
-5
00:00:00
23:59:55

23 59 30
30
23:59:30
00:00:00

6 57 9
-4195
06:57:09
05:47:14

Common Lisp（CLOS）の場合

(defclass Clock ()
  ((hour   :initform 0)
   (minute :initform 0)
   (second :initform 0)))
 
(defmethod setc ((c Clock) h m s)
  (setf (slot-value c 'hour  ) h)
  (setf (slot-value c 'minute) m)
  (setf (slot-value c 'second) s)
  t)
 
(defmethod to_str ((c Clock))
  (let ((h (slot-value c 'hour))
        (m (slot-value c 'minute))
        (s (slot-value c 'second)))
    (concatenate 'string
      (if (< h 10) "0" "") (write-to-string h) ":"
      (if (< m 10) "0" "") (write-to-string m) ":"
      (if (< s 10) "0" "") (write-to-string s))))
 
(defmethod shift ((c Clock) diff_second)
  (let ((h (slot-value c 'hour))
        (m (slot-value c 'minute))
        (s (slot-value c 'second)))
    (let ((tmp (+ (* h 3600) (* m 60) s diff_second)))
      (let* ((sd (mod (mod tmp 3600) 60))
             (md (mod (/ (- tmp sd) 60) 60))
             (hd (/ (- tmp sd (* md 60)) 3600)))
        (if (< hd 0) (setq hd (+ 24 hd)))
        (if (= hd 24) (setq hd 0))
        (if (< md 0) (setq md (+ 60 md)))
        (if (< sd 0) (setq sd (+ 60 hd)))
        (setc c hd md sd)
        t))))
 
(defparameter hour (read))
(defparameter mint (read))
(defparameter secd (read))
(defparameter diff (read))
 
(defparameter clk (make-instance 'Clock))
(setc clk hour mint secd)
(format t "~A~%" (to_str clk))
(shift clk diff)
(format t "~A~%" (to_str clk))

Emacs Lisp（EIEIO）の場合

• ドキュメント：EIEIO

Common Lispの場合の記述に次の修正を行うことで実行可能．

Common Lisp	Emacs Lisp
	冒頭で(require 'eieio)
(concatenate 'string ...)	(concat ...)
write-to-string	number-to-string
defparameter	setq
(format t "~A~%" ...)	(princ ...) (princ "\n")

Scheme（Gauche）の場合

• ドキュメント：7 オブジェクトシステム

(define-class <Clock> ()
  ((hour   :init-value 0)
   (minute :init-value 0)
   (second :init-value 0)))

(define-method setc! ((c <Clock>) h m s)
  (set! (ref c 'hour  ) h)
  (set! (ref c 'minute) m)
  (set! (ref c 'second) s))

(define-method to_str ((c <Clock>))
  (let ((h (ref c 'hour)) (m (ref c 'minute)) (s (ref c 'second)))
    (string-append
      (if (< h 10) "0" "") (number->string h) ":"
      (if (< m 10) "0" "") (number->string m) ":"
      (if (< s 10) "0" "") (number->string s))))

(define-method shift! ((c <Clock>) diff_second)
  (let ((h (ref c 'hour)) (m (ref c 'minute)) (s (ref c 'second)))
    (let ((t (+ (* h 3600) (* m 60) s diff_second)))
      (let* ((sd (mod (mod t 3600) 60))
             (md (mod (/ (- t sd) 60) 60))
             (hd (/ (- t sd (* md 60)) 3600)))
        (if (< hd 0) (set! hd (+ 24 hd)))
        (if (= hd 24) (set! hd 0))
        (if (< md 0) (set! md (+ 60 md)))
        (if (< sd 0) (set! sd (+ 60 hd)))
        (setc! c hd md sd)
        #t))))

(define hour        (read))
(define minute      (read))
(define second      (read))
(define diff_second (read))

(define clock (make <Clock>))
(setc! clock hour minute second)
(display (to_str clock)) (newline)
(shift! clock diff_second)
(display (to_str clock)) (newline)

Scheme（GNU Guile）の場合

• ドキュメント：8 GOOPS

(use-modules (oop goops))

(define-class <Clock> ()
  (hour   #:init-value 0)
  (minute #:init-value 0)
  (second #:init-value 0))

(define-method (setc! (c <Clock>) h m s)
  (slot-set! c 'hour   h)
  (slot-set! c 'minute m)
  (slot-set! c 'second s)
  #t)

(define-method (to_str (c <Clock>))
  (let ((h (slot-ref c 'hour))
        (m (slot-ref c 'minute))
        (s (slot-ref c 'second)))
    (string-append
      (if (< h 10) "0" "") (number->string h) ":"
      (if (< m 10) "0" "") (number->string m) ":"
      (if (< s 10) "0" "") (number->string s))))

(define-method (shift! (c <Clock>) diff_second)
  (let ((h (slot-ref c 'hour))
        (m (slot-ref c 'minute))
        (s (slot-ref c 'second)))
    (let ((t (+ (* h 3600) (* m 60) s diff_second)))
      (let* ((sd (modulo (modulo t 3600) 60))
             (md (modulo (/ (- t sd) 60) 60))
             (hd (/ (- t sd (* md 60)) 3600)))
        (if (< hd 0) (set! hd (+ 24 hd)))
        (if (= hd 24) (set! hd 0))
        (if (< md 0) (set! md (+ 60 md)))
        (if (< sd 0) (set! sd (+ 60 hd)))
        (setc! c hd md sd)
        #t))))

(define hour        (read))
(define minute      (read))
(define second      (read))
(define diff_second (read))

(define clock (make <Clock>))
(setc! clock hour minute second)
(display (to_str clock)) (newline)
(shift! clock diff_second)
(display (to_str clock)) (newline)

備考

記事に関する補足

• GaucheはCLOSスタイルを踏襲，GNU Guile（GOOPS）はよりSchemeスタイルって感じかな．僕が設計しろと言われたら，Scheme上でこんな感じで書けるといいなあとか．たいして違いはないか…．

(define Clock
  (class ()
    (hour :init-value 0)))

(define setc!
  (method ((c Clock) h)
    (set! c 'hour h)))

変更履歴

• 2020-08-27：Common Lisp，Emacs Lispの例を追加
• 2020-08-26：初版公開（Gauche，GNU Guile）