Skip to content

Instantly share code, notes, and snippets.

@cranebird
Last active November 3, 2015 13:25
Show Gist options
  • Save cranebird/828a73f10f687a51286b to your computer and use it in GitHub Desktop.
Save cranebird/828a73f10f687a51286b to your computer and use it in GitHub Desktop.
gauche-refj 「7.1 オブジェクトシステム」 の <ps-device> の試作。emacs のバッファに画像を表示する。
(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>)))
)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment