簡単なアルゴリズムの計算にはGaucheが便利なんだけど、それを視覚的に確認してみたくなったので簡単に実装。アドホックな実装。
Gaucheのオブジェクトシステムの練習という意味合いも込めて作ってみた。
tiny-ps.scmという名前でソースを保存し、Gaucheの *load-path* に置きます。
例えば
gosh> (use tiny-ps) gosh> (define *ps* (make/tps :bounding-box "0 0 200 200")) gosh> (closed-poly *ps* 0 0 100 200 200 0 0 120 200 120) gosh> (tps-preview *ps*) ; デフォルトでは /usr/bin/gv を使用
こうするといびつな星型が表示されます。
(define-module tiny-ps
(use srfi-19)
(use text.tree)
(use gauche.process)
(export <tiny-ps>
make-tiny-post-script
make/tps
with-tps
moveto
lineto
newpath
stroke
closepath
setlinewidth
setrgbcolor
poly
closed-poly
opened-poly
tps-preview
tps->string
tps-set-bounding-box!
tps-set-bb!))
(select-module tiny-ps)
(define-class <tiny-ps> ()
((stack :init-value '() :accessor ps-stack)
(ps-version :init-value "3.0"
:init-keyword :ps-version
:accessor ps-version)
(ps-type :init-value "eps"
:init-keyword :ps-type
:accessor ps-type)
(ps-title :init-value "Tiny PS figure"
:init-keyword :title
:accessor ps-title)
(ps-creator :init-value "Tiny PostScript Library"
:getter ps-creator)
(ps-creation-date
:init-form
(date->string (current-date) "~Y/~m/~d ~X")
:getter ps-creation-date)
(ps-bounding-box :init-value "0 0 100 100"
:init-keyword :bounding-box
:accessor ps-bounding-box)
(ps-preview-command :init-value "/usr/bin/gv"
:init-keyword :preview-command
:accessor ps-preview-command)
))
;;;;
;;;; not exported
;;;;
;;;; Primitive methods to treat primitive data
;;;;
(define-method tps-push ((ps <tiny-ps>) . items)
(cond ((null? items) (ps-stack ps))
((pair? (car items))
(begin
(apply tps-push ps (car items))
(apply tps-push ps (cdr items))))
(else
(begin
(set! (ps-stack ps) (cons (car items) (ps-stack ps)))
(apply tps-push ps (cdr items))))))
(define-method tps-pop ((ps <tiny-ps>))
(let* ((stack (ps-stack ps))
(poped (car stack)))
(begin
(set! (ps-stack ps) (cdr stack))
poped)))
(define-method tps-stack->string ((ps <tiny-ps>))
(string-join
(reverse
(map (lambda (x) (format #f "~a" x))
(ps-stack ps)))))
;;;;
;;;; exported
;;;;
;;;; Primitive methods corresponding to PostScript operator
;;;;
(define-syntax ps-operator
(syntax-rules ()
((_ op)
(define-method op ((ps <tiny-ps>))
(tps-push ps (symbol->string (quote op)))))
((_ op x)
(define-method op ((ps <tiny-ps>) x)
(tps-push ps x (symbol->string (quote op)))))
((_ op x ...)
(define-method op ((ps <tiny-ps>) x ...)
(tps-push ps x ... (symbol->string (quote op)))))))
(define-macro (with-tps ps . ops)
(let loop((ret '()) (ops (reverse ops)))
(cond ((null? ops) `(begin ,@ret))
(else
(loop
(let1 op (car ops)
(cons (cons (car op) (cons ps (cdr op)))
ret))
(cdr ops))))))
(ps-operator moveto x y)
(ps-operator lineto x y)
(ps-operator newpath)
(ps-operator stroke)
(ps-operator closepath)
(ps-operator setlinewidth linewidth)
(ps-operator setrgbcolor r g b)
(ps-operator setlinecap type)
(ps-operator setlinejoin type)
(ps-operator setdash pattern offset)
(ps-operator arc center-x center-y radius start-angle end-angle)
(ps-operator arcn center-x center-y radius start-angle end-angle)
;;;;
;;;; exported
;;;;
;;;; Methods wrapping primitive PostScript methods
;;;;
(define-method private-poly ((tps <tiny-ps>) . points)
(begin
(newpath tps)
(moveto tps (car points) (cadr points))
(let loop((points (cddr points)))
(cond
((null? points) #t)
(else
(let ((x (car points))
(y (cadr points)))
(begin
(lineto tps x y)
(loop (cddr points)))))))))
(define-method poly ((tps <tiny-ps>) . points)
(begin
(apply private-poly tps points)
(stroke tps)))
(define opened-poly poly)
(define-method closed-poly ((tps <tiny-ps>) . points)
(begin
(apply private-poly tps points)
(closepath tps)
(stroke tps)))
;;;;
;;;; exported
;;;;
;;;; Utility methods
;;;;
(define (make-tiny-post-script . options)
(apply make <tiny-ps> options))
(define make/tps make-tiny-post-script)
(define-method tps-set-bounding-box!
((ps <tiny-ps>) (str <string>))
(set! (ps-bounding-box ps) str)
(ps-bounding-box ps))
(define tps-set-bb! tps-set-bounding-box!)
(define-method tps-set-bounding-box!
((ps <tiny-ps>) (x0 <integer>) (y0 <integer>)
(x1 <integer>) (y1 <integer>))
(tps-set-bounding-box!
ps
(format #f "~a ~a ~a ~a" x0 y0 x1 y1)))
(define-method tps->string ((ps <tiny-ps>))
(tree->string
(list
"%!PS-Adobe-" (ps-version ps) #\newline
"%%Title: " (ps-title ps) #\newline
"%%Creator: " (ps-creator ps) #\newline
"%%CreationDate:" (ps-creation-date ps) #\newline
"%%BoundingBox: " (ps-bounding-box ps) #\newline
"%%Orientation: Landscape" #\newline
"%%DocumentFonts: (atend)" #\newline
"%%Pages: (atend)" #\newline
"%%EndComments" #\newline
"/tiny_ps_dict 120 dict def" #\newline
"tiny_ps_dict begin gsave" #\newline
(tps-stack->string ps) #\newline
"stroke end grestore showpage" #\newline
"%%Trailer" #\newline)))
(define-method tps-preview ((tps <tiny-ps>))
(begin
(with-output-to-file
(string-append "preview." (ps-type tps))
(lambda ()
(display (tps->string tps)))
:if-exists :overwrite
:if-does-not-exist :create)
(run-process (ps-preview-command tps)
(string-append "preview." (ps-type tps))
:wait #f)))
(export-all)
(provide "tiny-ps")