kakizome

kakizome.scm

#!/usr/local/bin/gosh

(use graphics.gd)
(use gauche.parseopt)

(define (usage)
  (print "Usage: kakizome <message> <name> <font>")
  (exit 1))


(define (string->string-list str)
  (map string (string->list str)))

(define (string-rectangle x y str font point)
  (gd-image-string-ft #f 0 font point 0 x y str))

(define (string-size str font point)
  (receive (a b c d)
      (string-rectangle 0 0 str font point)
    (let ((width (- (car b)(car a)))
          (height (- (cdr a)(cdr d))))
      (values width height))))

(define (string-max-width&height str font point)
  (let1 strls (string->string-list str)
    (let* ((size-ls (map (^s (receive (w h)
                                 (string-size s font point)
                               (cons w h))) strls))
           (max-width (apply max (map car size-ls)))
           (max-height (apply max (map cdr size-ls))))
      (values max-width max-height))))

(define (string->image-vertical str font point bgcolor fgcolor)
  (let* ((side-margin (quotient point 5))
         (bottom-margin (* side-margin 2))
         (top-margin (+ side-margin point))
         (signature-space 10))
    (receive (sw sh)
        (string-max-width&height str font point)
      (let* ((cw (+ sw side-margin signature-space))
             (ch (+ (* sh (string-length str)) bottom-margin))
             (image (gd-image-create-true-color cw ch))
             (x (+ (quotient side-margin 2) signature-space))
             (y top-margin))
        (gd-image-fill image 0 0 bgcolor)
        (let rec ((ls (string->string-list str))(y y))
          (unless (null? ls)
            (string! image  x y (car ls) :font font :fg fgcolor :pt point)
            (rec (cdr ls)(+ y sh))))
        (values image cw ch)))))

(define (write-signature! image signature font point fgcolor)
  (receive (sw sh)
      (string-max-width&height signature font point)
    (let* ((strls (reverse (string->string-list signature)))
           (ch (gd-image-sy image)))
      (let rec ((ls strls)(y (- ch (* sh 3))))
        (unless (null? ls)
          (string! image 5 y (car ls) :font font :fg fgcolor :pt point)
          (rec (cdr ls)(- y sh))))
      image)))


(define (main args)
  (let-args (cdr args)
      ((message "m|message=s")
       (font "f|font=s")
       (name "n|name=s")
       (help "h|help" => usage)
       (else (opt . _)
             (print "Unknown option : " opt)
             (usage))
       . rest)
    (let ((message (if (null? rest)
                       (read)
                       (car rest)))
          (name (if (or (null? rest)
                        (null? (cdr rest)))
                    (read)
                    (cadr rest)))
          (font (if (or (null? rest)
                        (null? (cdr rest))
                        (null? (cddr rest)))
                    (read)
                    (caddr rest)))
          (bgcolor (gd-true-color 255 255 255))
          (fgcolor (gd-true-color 0 0 0))
          (point 72))
      (let1 image (string->image-vertical message font point bgcolor fgcolor)
        (write-signature! image name font 12 fgcolor)
        (write-as image 'png (current-output-port))))))