gauche-refj 「7.1 オブジェクトシステム」 の <ps-device> の試作。emacs のバッファに画像を表示する。

emacsclient.scm

(use gauche.process)

;; 2015/11/03 by @quasicrane (cranebird)
;; gauche-refj 「7.1 オブジェクトシステム」 の <ps-device> の試作。
;; emacs のバッファに画像を表示する。

;; 前提:
;; - emacs の scheme-mode で REPL を起動させていること
;; - emacs が doc-view-mode を持っており、postscript をバッファに表示できること
;; - emacs が daemon モードで動作していること。 emacsclient がパスに存在すること。

;; eval-in-emacs - s式 exp を emacs 側で評価する。
;; exp を (write-to-string exp) した結果の文字列が emacs 側に渡るため、
;; emacs から見て正しい s 式になる必要がある。
(define (eval-in-emacs exp)
  (run-process
   `(emacsclient --eval) :redirects `((<<< 0 ,exp)) :wait #t))

;; test-draw - eval-in-emacs の例。
;; (test-draw '(100 . 700) '((10 . 30) (10 . 50) (10 . -20) (10 . -80) (10 . -50) (10 . 10) (10 . 40) (10 . 30)))
;; => emacs のバッファに折れ線が表示される。
(define test-draw
  (lambda (x xs)
    (eval-in-emacs
     `(progn
       (pop-to-buffer (generate-new-buffer " tmp-ps"))
       (insert "%!ps-adobe-3.0\n")
       (insert "newpath\n")
       (insert ,(x->string (car x)))
       (insert " ")
       (insert ,(x->string (cdr x)))
       (insert " moveto ")
       ,@(concatenate (map (lambda (y)
                `((insert ,(x->string (car y)))
                  (insert " ")
                  (insert ,(x->string (cdr y)))
                  (insert " rlineto "))) xs))
       (insert " stroke ")
       (insert " showpage")
       (doc-view-mode)))))

;; 以下は examples/oointro.scm をロードする必要がある。

;; buffer に表示する device
(define-class <ps-emacs-device> () ())
;; draw メソッドのとりあえず動く版。
;; 図は バッファの下の方に描画されるのでスクロールする必要があるかも
(define-method draw ((shapes <list>) (device <ps-emacs-device>))
  (let* ((device (make <ps-device>))
         (ps (with-output-to-string
                 (lambda ()
                   (format #t "%!PS-Adobe-3.0\n")
                   (for-each (cut draw <> device) shapes)
                   (format #t "showpage\n")))))
    (eval-in-emacs
     `(progn
       (pop-to-buffer (generate-new-buffer " tmp-ps"))
       (insert ,ps)
       (doc-view-mode)))))

;; examples/oointro.scm の shape-sample のコピー。
;; 最後の draw のデバイスだけ異なる。
(define (shape-sample-2)
  ;; creates 5 corner points of pentagon
  (define (make-corners scale)
    (map (lambda (i)
           (let ((pt (make <2d-point>)))
             (move-by! pt (make-polar scale (* i 2/5 pi)))
             (move-by! pt 200 200)
             pt))
         (iota 5)))

  (set! *shapes* '())  ;; clear the shape list
  (let* ((corners (make-corners 100)))
    ;; a pentagon in green
    (make <polyline-shape>
      :color '(0 1 0) :closed #t
      :points corners)
    ;; a star-shape in blue
    (make <polyline-shape>
      :color '(1 0 0) :closed #t
      :points (list (list-ref corners 0)
                    (list-ref corners 2)
                    (list-ref corners 4)
                    (list-ref corners 1)
                    (list-ref corners 3)))
    ;; put dots in each corner of the star
    (for-each (cut make <point-shape> :point <>)
              (make-corners 90))
    ;; draw the shapes 
    (draw *shapes* (make <ps-emacs-device>)))
  )