“与えられた木から、子→親への対応を作る”を Squeak Smalltalk で

http://d.hatena.ne.jp/scinfaxi/20080601/1212329435 経由で。

• Scheme:リスト処理 - 与えられた木から、子→親への対応を作る

チョロいもんだとナメてかかったら、たっぷり 30 分も費やしちまったことは内緒だ。(^_^;)

| tree translate |
tree :=
  #(Root (Spine (Neck (Head))
                (RClavicle (RUpperArm (RLowerArm (RHand))))
                (LClavicle (LUpperArm (LLowerArm (LHand)))))
         (RHip (RUpperLeg (RLowerLeg (RFoot))))
         (LHip (LUpperLeg (LLowerLeg (LFoot))))).

translate := [:tr |
    | result |
    result := OrderedCollection new.
    result addAll: (
        tr allButFirst collect: [:each |
            result addAll: (translate copy fixTemps value: each).
            each first -> tr first]); yourself].
^translate copy fixTemps value: tree

=>  an OrderedCollection(#Head->#Neck #RHand->#RLowerArm #RLowerArm->#RUpperArm 
#RUpperArm->#RClavicle #LHand->#LLowerArm #LLowerArm->#LUpperArm 
#LUpperArm->#LClavicle #Neck->#Spine #RClavicle->#Spine #LClavicle->#Spine 
#RFoot->#RLowerLeg #RLowerLeg->#RUpperLeg #RUpperLeg->#RHip #LFoot->#LLowerLeg 
#LLowerLeg->#LUpperLeg #LUpperLeg->#LHip #Spine->#Root #RHip->#Root #LHip->#Root)

Gauche に意訳。

(define *tree*
  '(Root (Spine (Neck (Head))
                (RClavicle (RUpperArm (RLowerArm (RHand))))
                (LClavicle (LUpperArm (LLowerArm (LHand)))))
         (RHip (RUpperLeg (RLowerLeg (RFoot))))
         (LHip (LUpperLeg (LLowerLeg (LFoot))))))

(define (translate tr)
    (let ((result '(())))
        (append (map (lambda (each)
            (set! (cdr result) (translate each))
            (cons (car each) (car tr))) (cdr tr)) (cdr result))))

(display (translate *tree*))

=> ((Spine . Root) (RHip . Root) (LHip . Root) (LUpperLeg . LHip) 
(LLowerLeg . LUpperLeg) (LFoot . LLowerLeg) (RUpperLeg . RHip) 
(RLowerLeg . RUpperLeg) (RFoot . RLowerLeg) (Neck . Spine) (RClavicle . Spine) 
(LClavicle . Spine) (LUpperArm . LClavicle) (LLowerArm . LUpperArm) 
(LHand . LLowerArm) (RUpperArm . RClavicle) (RLowerArm . RUpperArm) 
(RHand . RLowerArm) (Head . Neck))

ついでに Ruby への直訳も。

class Array; def all_but_first; self[1..-1] end end

tree =
  [:Root, [:Spine, [:Neck, [:Head]],
                [:RClavicle, [:RUpperArm, [:RLowerArm, [:RHand]]]],
                [:LClavicle, [:LUpperArm, [:LLowerArm, [:LHand]]]]],
         [:RHip, [:RUpperLeg, [:RLowerLeg, [:RFoot]]]],
         [:LHip, [:LUpperLeg, [:LLowerLeg, [:LFoot]]]]]

def trans(tr)
  result = []
  result.concat(
    tr.all_but_first.collect { |each|
      result.concat(trans(each))
      [each.first, tr.first]})
  result
end

p trans(tree)

=> [[:Head, :Neck], [:RHand, :RLowerArm], [:RLowerArm, :RUpperArm], 
[:RUpperArm, :RClavicle], [:LHand, :LLowerArm], [:LLowerArm, :LUpperArm], 
[:LUpperArm, :LClavicle], [:Neck, :Spine], [:RClavicle, :Spine], 
[:LClavicle, :Spine], [:RFoot, :RLowerLeg], [:RLowerLeg, :RUpperLeg], 
[:RUpperLeg, :RHip], [:LFoot, :LLowerLeg], [:LLowerLeg, :LUpperLeg], 
[:LUpperLeg, :LHip], [:Spine, :Root], [:RHip, :Root], [:LHip, :Root]]

付録：　Smalltalk から Ruby へ直訳するときの作業メモ

　　一時変数宣言 | temp1 temp2 |　　　　→　不要なので削除
　　式の末尾のピリオド .　　　　　　　　→　不要なので原則削除。あるいは ; に
　　リターン ^　　　　　　　　　　　　　→　return に。不要な場合は削除
　　ブロック [...]　　　　　　　　　　　→　{...}
　　ブロック変数宣言 :var1 :var2 |　　　→　| var1, var2 |
　　シンボルリテラル #sym 　　　　　　　→　:sym
　　等価比較 =　　　　　　　　　　　　　→　==
　　代入 := 　　　　　　　　　　　　　　→　= 
　　レシーバとメッセージの間のスペース　→　ピリオド
　　キーワードメッセージ kw: arg や kw1: arg1 kw2: arg2
　　　　　　　　　　　　　　　　　　　　→　kw(arg) や kw1_kw2(arg1, arg2) へ
　　配列の動的宣言 {式1. 式2. 式3...} 　→　[式1, 式2, 式3, ...] 
　　リテラル配列宣言 #(値1 値2 値3) も　→　[値1, 値2, 値3] 
　　無名関数としてブロック　　　　　　　→　proc を追加。あるいはメソッドとして定義
　　動的配列 OrderedCollection new　　　→　Array.new もしくは、空配列リテラル [] でＯＫ
　　カスケード ; と yourself を使ったイディオム
　　　　　　　　　　　　　　　　　　　　→　レシーバを返す記述に
　　配列要素のアクセス arr at: idx や arr at: idx put: #obj
　　　　　　　　　　　　　　　　　　　　→　arr[idx] や arr[idx] = :obj へ
　　配列要素のインデックスは１起点　　　→　０起点へ
　　動的配列への要素の追加 coll add: #obj や coll addAll: other
　　　　　　　　　　　　　　　　　　　　→　arr << :obj や arr += other（より厳密には arr.concat(other)）へ
　　Squeak Samlltalk でブロックをなんちゃって再帰させる場合の copy fixTemps
　　　　　　　　　　　　　　　　　　　　→　（他の Smalltalk も含め）不要なので削除