読み取りづらいQRコード(失敗)

moshでできる楽しい遊びを紹介する新コーナー     のはずが、初手から失敗してしまったので延期。

円錐形に加工して正面から取るとQRコードになっているような図を描いてみた。QRコードの生成は面倒なので予め用意しておいたものを使った。
どうも携帯電話の読み取りプログラムはパースペクティブにかなり依存しているらしくて、立体で読むように作ると失敗する模様。
一旦、読み取り用のカメラで補正用のパターンを取得しないとダメかな。。
ディスプレイリスト(line-toとかmove-toのような描画命令のリスト)の構築と座標変換、描画は絶対に標準ライブラリに必要。"この手の遊びをするならmosh"と呼ばれたい。イマドキ画像の描画も出来ないシェルも無いでしょうということで。
もっとも、↓のコードのような実装はあまりコンパイラにやさしくないという問題があって難しい。プログラミングは面倒になるけど、(line-to ctx x y)のような手続きの呼び出しの連続としてディスプレイリストを構築してもらうほうが色々と楽になる。少なくともcairoはそういうスタイルになっている。
ただ、手続き呼び出しでディスプレイリストを作るという考え方はそろそろ時代遅れで、例えばOpenGL ESのような最近のOpenGLではAPIに対して配列を渡して一気に構築するスタイルになっている。だから何らかの手法で(多分VMレベルで)ジェネリックなリスト操作をサポートして、単純なリスト操作としてディスプレイリストを構築できるようにするほうが、将来への発展性が期待できる。
例えばGaucheはコレクションとかシーケンスという形で、文字列やベクタのような様々な"リスト風のオブジェクト"にジェネリックなmapやfoldを提供している。
cutの使い方が非常に微妙だなぁ。。個人的にはわかりやすいけどもっと良い書き方が有るかもしれない。あと、全体的に書き方が効率悪い。基本的には上から順番に書いていって一撃で動かしている。

(import (rnrs)
        (srfi :8)
        (srfi :26)
        (match)
        (mosh ffi))

(define libcaironame "libcairo-2.dll")

(define libcairo (open-shared-library libcaironame))

(define cairo-pdf-surface-create (c-function libcairo void* cairo_pdf_surface_create char* double double))
(define cairo-surface-write-to-png (c-function libcairo int cairo_surface_write_to_png void* char*))
(define cairo-surface-destroy (c-function libcairo void cairo_surface_destroy void*))
(define cairo-destroy (c-function libcairo void cairo_destroy void*))
(define show-page (c-function libcairo void cairo_surface_show_page void*))
(define cairo-create (c-function libcairo void* cairo_create void*))
(define cairo-fill (c-function libcairo void cairo_fill void*))
(define set-line-width (c-function libcairo void cairo_set_line_width void* double))
(define rgba (c-function libcairo void cairo_set_source_rgba void* double double double double))
(define move-to (c-function libcairo void cairo_move_to void* double double))
(define line-to (c-function libcairo void cairo_line_to void* double double))

(define (draw-pdf filename l)
  (define (draw-ops ctx l)
    (define (draw-one e)
      (match e
             (('line-to x y) (line-to ctx (inexact x) (inexact y)))
             (('move-to x y) (move-to ctx (inexact x) (inexact y)))
             (('fill) (cairo-fill ctx))
             (else #f)))
    (for-each draw-one l))

  (let* ((surface (cairo-pdf-surface-create filename 300.0 300.0))
         (ctx (cairo-create surface)))
    (rgba ctx 0.2 0.2 0.2 1.0)
    (set-line-width ctx 0.0)
    (draw-ops ctx l)
    (show-page surface)
    (cairo-destroy ctx)
    (cairo-surface-destroy surface)))

(define (linelister port)
  (let loop ((cur '()))
    (let ((l (get-line port)))
      (if (eof-object? l)
        (reverse cur)
        (loop (cons l cur))))))

(define indata
  (call-with-input-file "in.txt" linelister))

(define (str01->drawop str)
  (define (line-itr x0 y0 xd yd step cur)
    (if (= step 0)
      (reverse cur)
      (line-itr (+ x0 xd) (+ y0 yd) xd yd (- step 1)
                  (cons
                    `(line-to ,x0 ,y0) cur))))
  (define (line x0 y0 x1 y1 step)
    (line-itr x0 y0 (/ (- x1 x0) step) (/ (- y1 y0) step) step '()))

  (define (point x y step)
    (append `((move-to ,x ,y))
            (line (+ x 0) (+ y 0) (+ x 1) (+ y 0) step)
            (line (+ x 1) (+ y 0) (+ x 1) (+ y 1) step)
            (line (+ x 1) (+ y 1) (+ x 0) (+ y 1) step)
            (line (+ x 0) (+ y 1) (+ x 0) (+ y 0) step)
            `((line-to ,x ,y))
            '((fill))))

  (define (step c e)
    (let ((idx (car c))
          (cur (cdr c)))
      (cons (+ 1 idx)
            (if (equal? e #\0 )
              cur
              (append (point idx 0 32) cur)))))
  (let ((l (string->list str)))
    (cdr (fold-left step (cons 0 '()) l))))

(define (get-xy o)
  (match o
         (('move-to x y) (list x y))
         (('line-to x y) (list x y))
         (else #f)))

(define (set-xy o x y)
  (match o
         (('move-to a b) (list 'move-to x y))
         (('line-to a b) (list 'line-to x y))
         (else #f)))

(define (mymap1 proc l)
  (define (mymap1-itr cur in)
    (if (pair? in)
      (mymap1-itr (cons (proc (car in)) cur) (cdr in) )
      (reverse cur)))
  (mymap1-itr '() l))

(define (pixel-map proc l)
  (define (step e)
    (let ((p (get-xy e)))
      (if p
        (receive (x y) (apply proc p)
          (apply set-xy (list e x y)))
        e)))
  (display (list "mapping : " (length l)))(newline)
  (mymap1 step l))

(define (scale0 x y r)
  (values
    (* x r)
    (* y r)))

(define (shift x y xo yo)
  (values
    (+ x xo)
    (+ y yo)))

(define (rot x y r)
  (define rr (* (/ r 360) 3.14159 2))
  (let ((z (make-rectangular x y)))
    (let ((zz (make-polar
                (magnitude z)
                (+ (angle z) rr))))
      (values (real-part zz) (imag-part zz)))))

(define (map/index proc l)
  (define (itr cur idx cl)
    (if (pair? cl)
      (itr (cons (proc idx (car cl)) cur) (+ 1 idx) (cdr cl))
      (reverse cur)))
  (itr '() 0 l))

(define (strlist->drawop l)
  (let* ((len (string-length (car l)))
         (de (map str01->drawop l))
         (p (map/index
              (lambda (idx e)
                (pixel-map (cut shift <> <> 0 idx) e)) de)))
    (pixel-map (cut shift <> <> -1/2 -1/2)
               (pixel-map (cut scale0 <> <> (/ 1 len))
                          (fold-left (lambda (cur e) (append e cur)) '() p)))))

(define (mymap0 x y)
  (let ((z (make-rectangular x y)))
    (let ((zz (make-polar
                (magnitude z)
                (* (angle z) 5/6))))
      (values (real-part zz) (imag-part zz)))))

(define rindata (pixel-map (cut rot <> <> 136) (strlist->drawop indata)))
(define res (pixel-map mymap0 rindata))

(draw-pdf "draw.pdf"
          (pixel-map (cut shift <> <> 150 150)
                     (pixel-map (cut scale0 <> <> 150) res)))