GraphVizを使ったぞ。

GraphVizは、dot言語でグラフを記述してpdfやpngとかで出力できる。

GraphViz for discrete math studentsというページでdotのサンプルを確認した。
僕の場合、重み付き有向グラフの描画をできれば良いのでこれだけでよかった。

<雑なdotサンプル>

digraph {
    a -> b[label="0.1",weight="0.1"];
    b -> c[label="0.2",weight="0.2"];
    c -> a[label="0.3",weight="0.3"];
}

weightは、重みをいれたらいいのは分かるが、ラベルとして表示されるわけではなかった。
グラフ描画をいいかんじにしてくれるというくらいの認識。

↓manはこう言ってました。

weight=n where n is the integer cost of the edge. 
         Values greater than 1 tend  to  shorten  the  edge.
Weight 0 flat edges are ignored for ordering nodes.

f:id:niyarin-man:20170204202921p:plain
おしまい。

雑に型推論するものを書いたぞ。

方程式を導出してそれを解くということをしただけ。

サポートする構文、組み込み関数

構文
ifとfunとlambda(1つ以上の引数関数の糖衣構文として)

(if bool a a)
(fun x body)
(lambda (x1 x2 ... ) body)

組み込み関数
succ + zero? の3つだけ。

関数適用
(zero? (+ 1 2))
;boolean

整数をいれて、2加えて返す関数
(fun a (succ (succ a))) 
;integer -> integer

多相型
(fun a a)
;T4 -> T4

ifの型推論
(lambda (a b)(if a 1 b))       
;boolean -> integer -> integer

合成関数
(lambda (a b)(fun x (a (b x))))
;(T10 -> T11) -> (T9 -> T10) -> T9 -> T11

雑なソースコード

;-----------------------------------------------------
;
;             data
;
;-----------------------------------------------------


(define builtin-functions
  '((succ . (function . (integer . integer)))
    (+ . (function . (integer . (function . (integer . integer)))))
    (zero? . (function . (integer . boolean)))))
  




;-----------------------------------------------------
;
;             curry
;
;-----------------------------------------------------


(define (lmd-to-curry-fun code)
  (let ((param (cadr code))
        (body (caddr code)))
    (let loop ((p param))
        (if (null? p)
          body
          `(fun ,(car p) ,(loop (cdr p)))))))

(define (curry-apply code)
  (let loop ((args (reverse (cdr code))))
    (if (null? (cdr args))
      `(,(car code) ,(car args))
      `(,(loop (cdr args)) ,(car args)))))



(define (test-convert code)
  (if (pair? code)
    (case (car code) 

      ((lambda) 
         (let ((body (test-convert (caddr code))))
           (lmd-to-curry-fun `(lambda ,(cadr code) ,body))))

      ((fun) 
       (let ((body (test-convert (caddr code))))
         `(fun ,(cadr code) ,body)))

      ((if)
       (let ((test (test-convert (cadr code)))
             (true (test-convert (caddr code)))
             (false (test-convert (cadddr code))))
         `(if ,test ,true ,false)))

      (else 
        (let ((args (map test-convert (cdr code)))
              (f (test-convert (car code))))
                (curry-apply (cons f args)))))
    code))




;-----------------------------------------------------
;
;             type inference
;
;-----------------------------------------------------


(define extract #f)
(let ((type-vars 0))
  (define (publish-type-vars)
    (set! type-vars (+ type-vars 1))
    (cons 'type-var type-vars))
  (define (catch-type env sym)
    (cond ((assv sym env) => cdr)
    (else (display "ERROR::unbound variable ")(display sym)(display "   env=")(display env)(newline))))
  (set! extract
    (lambda (env code)
      (cond 
        ((integer? code) '(() . integer))
        ((boolean? code) '(() . boolean))
        ((symbol? code) (cons '() (catch-type env code)))
        ((eqv? (car code) 'if)
          (let* ((et1 (extract env (cadr code)))
                 (et2 (extract env (caddr code)))
                 (et3 (extract env (cadddr code))))
            (let ((e4 (append 
                          (car et1) 
                          (car et2) 
                          (car et3)
                        (list (cons (cdr et1) 'boolean)
                              (cons (cdr et2) (cdr et3))))))
              (cons e4 (cdr et2)))))
        ((eqv? (car code) 'fun)
         (let ((t (publish-type-vars)))
           (let ((et0 (extract (cons (cons (cadr code) t) env) (caddr code))))
             (cons (car et0) (cons 'function (cons t (cdr et0)))))))
        (else
          (let* ((et1 (extract env (car code)))
                 (et2 (extract env (cadr code))))
            (let ((t (publish-type-vars)))
              (let ((e3 (append
                          (car et1) 
                          (car et2)
                          (list (cons (cdr et1) (cons 'function (cons  (cdr et2) t)))))))
                (cons e3 t)))))
        ))))







(define (expand obj env)
  (cond 
    ((type-var? obj) 
       => (lambda (id) 
            (let loop ((p env)) 
              (cond 
                ((null? p) obj)
                ((eqv? id (caar p))(cdar p))
                (else (loop (cdr p)))))))
    (else obj)))
    

(define (expand-rec obj env)
    (cond 
      ((symbol? obj) obj)
      ((type-var? obj)
       (let ((expanded-obj (expand obj env)))
         (if (and (type-var? expanded-obj) (eqv? (type-var? expanded-obj)(type-var? obj)))
           expanded-obj
           (expand-rec expanded-obj env))))
      ((eqv? (car obj) 'function)
       `(function . (,(expand-rec (cadr obj) env) . ,(expand-rec (cddr obj) env))))
      (else obj)))
                


(define (unify e equations)
  (cond 
    ((null? equations) e)
    ((null? (car equations)) (unify e (cdr equations)))
    (else
      (let ((left (expand (caar equations) e))
            (right (expand (cdar equations) e)))
        (cond
          ((equal? left right) (unify e (cdr equations)))
          ((and (not (type-var? right)) (type-var? left) )
            => (lambda (id) (unify (cons (cons id right) e) (cdr equations))))
          ((and (not (type-var? left)) (type-var? right))
            => (lambda (id) (unify (cons (cons id left) e) (cdr equations))))
          ((and (pair? left)(pair? right) (eqv? (car left) 'function) (eqv? (car right) 'function))
           (unify e `(,(cons (cadr left)(cadr right)) ,(cons (cddr left)(cddr right)) . ,(cdr equations))))
          (else  (display "TYPE ERROR")(newline)))))))

          
        
(define (type-var? o)
  (and (pair? o)(eqv? (car o) 'type-var)(cdr o)))



(define (type->string obj)
  (cond 
    ((symbol? obj) (symbol->string obj))
    ((eqv? (car obj) 'type-var) (string-append "T" (number->string  (cdr obj))))
    ((eqv? (car obj) 'function) 
     (let ((arg 
             (if (and (pair? (cadr obj)) (not (type-var? (cadr obj))))
               (string-append "(" (type->string (cadr obj)) ")")
               (type->string (cadr obj))))
           (body (type->string (cddr obj)))) 
       (string-append arg  " -> "  body )))))
     


;-----------------------------------------------------
;
;             REPL
;
;-----------------------------------------------------

(define (eqshow eqs)
  (let loop ((l eqs))
    (cond 
      ((null? l) '())
      ((null? (car l)) (loop (cdr l)))
      (else (display ":::::  ")(display (caar l))(display " = ")(display (cdar l))(newline)(loop (cdr l))))))


(let type-check-loop ()
  (let* ((input (test-convert (read)))
         (analyzed-input (extract builtin-functions input))
         (kai (unify '() (car analyzed-input)))
         (ret (expand-rec (cdr analyzed-input) kai)))
    (display (type->string ret))(newline)
    (type-check-loop)))

gentooの/etc/portage/distfilesをきれいにするぞ

ecleanを使う。
標準では入っていないので、gentoolkitを入れる必要がある。

dオプションをつけると、現在のバージョン以外が消える。(man曰く、only keep the minimum for a reinstallation)
日付やサイズ等のオプションもつけられるが、再ダウンロードすればよいので気にせず消した。

eclean distfiles -d

scheme処理系を実装中です。

Kobe University Advent Calendar 2016の22日目の記事です。
そして私はB3のniyarinです。


本編に関係ないネタ

本編が少し雑なので、xmas treeを出力するスクリプトをてきとーにschemeで書きました

(define decorate #f)
(let ((pos-seed 1)
      (shape-seed 1))
  (set! decorate
    (lambda (leaves)
      (for-each 
        (lambda (_) 
          (set! pos-seed (modulo (+ (* pos-seed 3) 7) 26))
          (set! shape-seed (modulo (+ shape-seed 1) 3))
          (if (< pos-seed (string-length leaves))
            (string-set! leaves pos-seed
                         (list-ref '(#\@ #\? #\$) shape-seed)))) 
        (make-list 3))
      leaves)))


(define tree-data 
    (let loop1 ((width '( 0 2 6 10 ))(updates '(1 1 2 2 ) ))
      (if (null? width) 
        '()
        (append 
          (let loop2 ((w (min 1 (car width))))
            (if (> w (car width))
              '()
              (cons 
                (string-append
                  (substring "                             " 0 (- 13 w))
                  (decorate (substring "*********************" 0 (+ (* w 2) 1))))
                (loop2 (+ w (car updates) )))))
          (loop1 (cdr width)(cdr updates))))))

(define tree-pot
  (let ((space "          ")
        (edge  "|     |")
        (bottom "-------"))
    (append
      (map (lambda (_)
             (string-append space edge))
           (make-list 2 ))
      (list (string-append space bottom)))))


(for-each 
  (lambda (x) (display x)(newline))
  (append tree-data tree-pot))


結果

             *
            *?*
           *****
            *?*
          *******
        *?*********
            ***
          *?*****
        **********$
      *?*************
    **********$@**?****
          |     |
          |     |
          -------

ネタおしまい。

scheme処理系を実装している話

・未完成です。
・上のxmas tree scriptも動きません
ページ
今回は、中でどんな処理をしているのか雑に説明します。

処理系の概要

・r7rsを目指す。
JavaScriptで実装。
VM

終わったこと

・末尾呼び出し最適化
・末尾呼び出しでなくても最適化する
・syntax-rules
・第一級継続
・dynamic-wind
・多値

コンパイル手順

α変換&マクロ展開&syntax展開 → cps conversion → closure conversion & lambda lifting →VMコード生成

α変換

名前の衝突は後の処理で厄介になりそうなのでリネームします。

(lambda (a)(lambda (a) (+ a 1))) -> (lambda (a) (lambda (a_2) (+ a_2 1)))

cps conversion

継続を陽に表すようなコードに変換します。
私の処理系では、これを第一級継続、末尾呼び出し最適化に使用しているので割と大事な処理だったりします。

(+ (+ a b)(+ c d))
->
  (+ a b (lambda (r1) 
           (+ c d (lambda (r2) (+ r1 r2 ret)))))


closure conversionとlambda lifting

自由変数を削除する変換です

lambda liftingはlambda式のparameterを拡張する変換です

(let ((a 1))
  ((lambda (b c) (+ a b c )) 2 3))
->
(let ((a 1))
  ((lambda (b c a)(+ a b c )) 2 3 a ))


closure conversionは、closureを手続きと自由変数の値のペアで表現するという変換です。

末尾呼び出し最適化

すべての手続き呼び出しで、call stackを必要としないコードに変換することで実現しました。
具体的には、cps conversionで戻りアドレスを不要にして、 closure conversionで外の自由変数を削除するという方針です。

おしまい

syntax-rulesの仕様を読んで確認した

r7rsのsyntax-rulesのパターンの部分の仕様を読んで確認する。(vectorは省く)

とる形は、以下の4つ(Pはパターンで、[ellipsis]は、0個以上の繰り返し)
1. (P1 ... Pn )
2. (P1 ... Pn . Pn+1)
3. (P1 ... Pk Pe [ellipsis] Pm+1 ... Pn)
4. (P1 ... Pk Pe [ellipsis] Pm+1 ... pn . Px )

つまり、
1.真性リストで[ellipsis]を含まない。
2.非真性リストで[ellipsis]を含まない。
3.真性リストで[ellipsis]を含む。
4.非真性リストで[ellipsis]を含む。
ということか。

1

(define-syntax check-1
  (syntax-rules () ((_ (a b c d e)) (quote (a b c d e)))))


(display (check-1 (1 2 3 4 5)))(newline) ;(1 2 3 4 5)

真性リストで同じ要素数のものだけしかマッチしない。
特になし

2

(define-syntax check-2
  (syntax-rules () ((_ (a b . c))(quote (a b c)))))


(display (check-2 (1 2 )))(newline);(1 2 ())
(display (check-2 (1 2 3 )))(newline);(1 2 (3))
(display (check-2 (1 2 3 4 5)))(newline);(1 2 (3 4 5))
(display (check-2 (1 2 . 3)))(newline);(1 2 3)

非真性、真性どちらでもよく、左から順にマッチさせていき、のこりを最後のcdr部にマッチさせる。
これも、特になし。

3

(define-syntax check-3
  (syntax-rules () ((_ (a b ... c d ))(quote (a b ... c d )))))

(display (check-3 (1 2 3 4 5)))(newline);(1 2 3 4 5)
(display (check-3 (1 2 3)))(newline);(1 2 3)

真性リストで、[ellipsis]の左側と右側をマッチさせて、残りを[ellipsis]の所にマッチさせる。
これも、特になし。

4-1

全部、パターン変数の場合。

(define-syntax check-4a
  (syntax-rules () ((_ (a b ... c . d))(quote (b ...  d  )))))

(display (check-4a (1 2 3  4 5)))(newline);(2 3 4 ())
(display (check-4a (1 2 3 4 . 5)))(newline);(2 3 5)
(display (check-4a (1 2 3)))(newline);(2 ())

処理系によっては、動かなかったり、明らかに間違った結果がでたりした。
saggitarius0.6.11やgauche0.9.5の結果だと、
非真性リストを入れると、末尾cdr同士、それ以外同士でマッチングし、
真性リストを入れると、patternの末尾cdrにnullがマッチして、全部その左側にマッチする。

4-2

定数を入れた場合。

(define-syntax check-4b
  (syntax-rules () ((_ (1 2 ... 3 . d))(quote d ))))

(print (check-4b (1 2 2 2 3 . 4 )));4

真性リストを入力した場合、最後のcdr要素(null)だけが、Pxにマッチするので、
Pnまでうまくマッチできそうなケースでもだめだね。

ウサギとカメ(循環リスト)

連結リストで循環しているかどうか、どこで循環が始まっているのかを検出する。
正式には、Floyd's cycle-finding algorithmと呼ぶらしい。
証明は省くが、だいたい↓のような手順

循環判定

・セルを2つづつ移動するのをウサギ、1つづつ移動するのをカメとして、1ステップずつシミュレートする。
・ウサギとカメが出会う(同じセルにいる)場合そのリストは循環している。

循環場所の検出

・ウサギを最初のセルにもどし、ウサギのスピードを1にする。
・再度シミュレートして、ウサギとカメが出会ったセルが循環のスタート地点。

コード

hare:ウサギ
tortoise:カメ

is_circle_listは、循環リストなら循環スタートのセルを返し、そうでなければfalseを返す。

var Cell = function(a,b){
    this.car = a;
    this.cdr = b;
}

var is_circle_list = function(ls){
    var hare = ls;
    var tortoise = ls;
    while (true){
        if (hare.cdr == null || hare.cdr.cdr == null){
            return false;
        }
        hare = hare.cdr.cdr;
        tortoise = tortoise.cdr;

        if (hare == tortoise){
            break;
        }
    }
    
    hare = ls;
    while (true){
        if (hare == tortoise){
            break;
        }
        hare = hare.cdr;
        tortoise = tortoise.cdr;
    }
    return hare;
}

schemeのパラメータオブジェクトの使い方を調べた。

r7rsでは標準。

パラメータオブジェクトは、値を束縛して動的存続期間中にその値を変更できるオブジェクト。
make-parameterで、パラメータオブジェクトを作れる。

(define foo (make-parameter 123))
(foo);123



パラメータオブジェクトに値を渡した時の挙動は処理系依存とされているが、 CHICKEN,picrinなど、値を変更するケースが多い。

(foo);123
(foo 100)
(foo);100



parameterizeを使うと、その中でのパラメータオブジェクトが返す値を変更できる。

(foo);123
(parameterize ((foo 10)) (foo));10
(foo);123



make-parameterに2つ引数(init converter)を渡すと、初期化や値の変更時に converterを通した値がセットされる。

(define boo (make-parameter 123 (lambda (x) (* x x ))))
(boo);15129
(boo 3);9