“与えられた木から…”の Gauche な皆さんの回答を Squeak Smalltalk に訳してみる

Scheme から表現力の劣る Smalltalk に移そうとすれば、当然、いろいろと抜け落ちてしまい、結果として身も蓋もなくなっちゃっていかんのですが…。まあそこはそれとして(^_^;)。個人的には nfunato さんのがお気に入りです。

それにつけても、copy fixTemps だらけで、Squeak Smalltalk のブロックで再帰なんかやるもんじゃあないですね。orz（くどいようですが、aBlock copy fixTemps というのは、そのままでは再入・再帰ができない Squeak のブロックで、自身と環境のコピーを行なうための作業です。もちろん、無名関数としてのブロックがクロージャで実現されている通常の Smalltalk では不要）。

▼ id：scinfaxi さんの

• http://d.hatena.ne.jp/scinfaxi/20080601/1212329435

| tree result loop |

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


result := OrderedCollection new.

loop := [:xs :parent |
    xs allButFirst isEmpty ifTrue: [nil] ifFalse: [
        xs allButFirst do: [:x |
            parent ifNotNil: [result add: x first -> parent].
            loop copy fixTemps valueWithArguments: {x. xs first}]]].
loop copy fixTemps valueWithArguments: {tree. #f}.

^result

▼ Pla さんの

• 素直に書いて…

| tree result loop |

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

result := OrderedCollection new.

loop := [:tr |
    | parent children |
    tr size > 1 ifTrue: [
        parent := tr first.  children := tr allButFirst.
        children do: [:child |
            loop copy fixTemps value: child.
            result add: child first -> parent]]].
loop copy fixTemps value: tree.

^result

▼ naoya_t さんの

• 最初に書いたやつから…

| tree appendMap itr foo2 foo3 |

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

appendMap := [:proc :l |
    (l collect: proc)
        inject: OrderedCollection new
        into: [:colln :each | colln addAll: each; yourself]].

"foo1"
itr := [:p :t |
    {t first -> p}, (
        t allButFirst ifEmpty: [#()] ifNotEmpty: [
            appendMap copy fixTemps
                value: [:x | itr copy fixTemps value: t first value: x]
                value: t allButFirst])].
appendMap copy fixTemps
    value: [:x | itr copy fixTemps value: tree first value: x]
    value: tree allButFirst.


foo2 := [:l |
    | parent children |
    parent := l first.
    children := l allButFirst.
    appendMap copy fixTemps
        value: [:child |
            {child first -> parent}, (
                child allButFirst isEmpty ifTrue: [#()] ifFalse: [
                    foo2 copy fixTemps value: child])]
        value: children].
foo2 copy fixTemps value: tree.


foo3 := [:l |
    appendMap copy fixTemps
        value: [:child |
            {child first -> l first}, (
                child allButFirst isEmpty ifTrue: [#()] ifFalse: [
                    foo3 copy fixTemps value: child])]
        value: l allButFirst].
foo3 copy fixTemps value: tree


"foo4 は省略 "

▼ Shiro さんの

• あんま流行らなかったな…

| tree rec |

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

"get-parent-alist"
rec := [:p :t :s |
    | n ts |
    n := t first.  ts := t allButFirst.
    {n -> p}, (ts inject: s into: [:result :each |
        rec copy fixTemps valueWithArguments: {n. each. result}])].


^tree allButFirst inject: #() into: [:result :each |
    rec copy fixTemps valueWithArguments: {tree first. each. result}]

▼ nfunato さんの

• Shiroさんの解から得た版(本質は同じ)を追記…

| tree getParentAlist gather build |

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

getParentAlist := [:p |
    (p allButFirst collect: [:c | c first -> p first]),
        (p allButFirst collect: getParentAlist copy fixTemps) concatenation].

getParentAlist copy fixTemps value: tree.


"Shiroさんのを元にしたもの"
build := nil.
gather := [:p :soFar |
    p allButFirst inject: soFar into: [:result :each |
        build copy fixTemps valueWithArguments: {p. each. result}]].

build := [:p :c :soFar |
    {c first -> p first}, (gather copy fixTemps value: c value: soFar)].

gather copy fixTemps value: tree value: #()

▼ nobsun さんの

• でおくれた。得意な…

| tree appendMap dfs chpa |

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

appendMap := [:proc :l |
    (l collect: proc)
        inject: OrderedCollection new
        into: [:colln :each | colln addAll: each; yourself]].

dfs := [:t | {t}, (appendMap copy fixTemps value: dfs copy fixTemps value: t allButFirst)].

"tree-child-parent-list"
chpa := [:t |
    | p cs |
    p := t first.  cs := t allButFirst.
    (cs collect: [:each | each first]) collect: [:each | each -> p]].

appendMap copy fixTemps value: chpa copy fixTemps value: (dfs copy fixTemps value: tree)