Smalltalk-76 とアルト・エミュレータ(ContrAlto)でマンデルブロ集合

最後はやっぱりアルト実機に対抗(?)して、アルト・エミュレーターContrAlto で動く Smalltalk-76 で書いたマンデルブロ集合描画で締めくくりたい…と思ったのですが、想像以上に遅くてけっこう大変でした。^^;


Smalltalk-76 を動作させるにあたり こちら のディスクパック・イメージ xmst76.dsk44 を使用させていただきました。Smalltalk-76 の起動は resume xmsmall.boot です。


Smalltalk-76 は、Pharo や Squeak Smalltalk の元になっている Smalltalk-80 と似たところが多い(初期の Smalltalk-72 と比べればはるかに!)ですが、それでもいろいろと勝手が違うところもあるので「過渡期」と見るだけでなく「Smalltalk-80とは似て非なる独自の言語」として見ても興味深い処理系です。こちらの文書が参考になります。


ContrAlto Readme には raw packet を使いたいときだけのように書いてありますが、Microsoft Visual C++ 2010 redistributable は設定画面(System → System Configuration...)を正常に機能させるのにも必要ですのでネットに繋げなくとも忘れずにインストールしておきましょう。同設定から Displayタブの Throttle Framerate at 60 frame/sec のチェックを外しておくと手元の環境では気持ち快適に動作しました。あと、ホイールボタンが使用できる3ボタンマウスが必須です。


まずは、複素空間の座標を Point で表わす方法で素朴に書いてみたのがこちら。

http://squab.no-ip.com/collab/uploads/mandelbrot11.png

| size half origin turtle limit start x y c z count zsquared [
   size ← 10.
   half ← size/2.
   origin ← Rectangle new fromuser origin.
   (origin - 1 extent: size⌾size + 2) outline; clear: black.
   turtle ← Turtle init.
   limit ← 10.
   start ← user rawtotalsecs.
   for⦂ y from: (0 to: size-1) do⦂ [
      for⦂ x from: (0 to: size-1) do⦂ [
         c ← x asFloat ⌾ y asFloat - half / half - (0.5⌾0).
         z ← 0.0⌾0.0.
         count ← 0.
         while⦂ ((count ← count + 1) ≤ limit and⦂ z length < 2) do⦂ [
            zsquared ← z x * z x - (z y * z y) ⌾ (2.0 * z x * z y).
            z ← zsquared + c
         ].
         [count > limit ⇒ [turtle black] turtle white].
         turtle penup; place: x⌾y + origin; pendn; go: 0
      ]
   ].
   user rawtotalsecs - start
]


ポイント記号 ⌾ は ctrl + ] 、オープンコロン ⦂ は ctrl + ; 、小なりイコール ≤ は ctrl + , 、〜ならば ⇒ は ctrl + / で入力できます(US キーボードの場合)。


走らせてみたところ 10×10ドット(左下の小さいやつ!)で集合値判定ループも最大10回にまで減らしたにもかかわらず描き終えるのに 6分近くかかるという状態。この様子では全画面はおろか、100×100 でも、おそらく1日かけても終わりません。BCPL よりは遅いかな…程度に軽く考えていましたが、あまかった!


念のため、Squeak Smalltalk でほぼ同じ意味になるように書き換えたのがこちら。100×100ドット、判定ループ最大100回でも 0.2秒ほどで終わります。いい時代になりました。w

| size half origin turtle limit start c z count zsquared |
size := 100.
half := size/2.
origin := Rectangle fromUser origin.
Display border: ((origin extent: size asPoint) expandBy: 2) width: 2 fillColor: Color black.
turtle := Pen new.
limit := 100.
start := Time millisecondClockValue.
(0 to: size-1) do: [:y |
   (0 to: size-1) do: [:x |
      c := x asFloat @ y asFloat - half / half - (0.5@0).
      z := 0.0@0.0.
      count := 0.
      [(count := count + 1) <= limit and: [z r < 2]] whileTrue: [
         zsquared := z x * z x - (z y * z y) @ (2.0 * z x * z y).
         z := zsquared + c
      ].
      turtle color: (count > limit ifTrue: [Color black] ifFalse: [Color white]).
      turtle up; place: x@y + origin; down; go: 0
   ]
].
Time millisecondClockValue - start / 1000.0 "=> 0.211 "


そこで、Point の使用を諦め、主に型変換のコストがかからないように最低限の変更を加えてみたのがこちらです。

http://squab.no-ip.com/collab/uploads/mandelbrot09.png

| size half ori turtle limit start x y cre cim zre zim zre2 zim2 count [
   size ← 101.
   half ← size/2.
   ori ← Rectangle new fromuser origin.
   (ori extent: size asPoint) outline; clear: black.
   turtle ← Turtle init.
   limit ← size/3.
   start ← user rawtotalsecs.
   for⦂ y from: (0 to: half) do⦂ [
      for⦂ x from: (0 to: size-1) do⦂ [
         cre ← x asFloat - half / half - 0.5.
         cim ← y asFloat - half / half.
         zre ← zim ← zre2 ← zim2 ← 0.0.
         count ← 1.
         while⦂ (count ≤ limit and⦂ zre2 + zim2 < 4.0) do⦂ [
            zim ← 2.0 * zre * zim + cim.
            zre ← zre2 - zim2 + cre.
            zim2 ← zim * zim.
            zre2 ← zre * zre.
            count ← count + 1
         ].
         [count > limit ⇒ [turtle black] turtle white].
         turtle penup; place: x + ori x ⌾ (y + ori y); pendn; go: 0.
         turtle penup; place: x + ori x ⌾ (size - y - 1 + ori y); pendn; go: 0
      ]
   ].
   user rawtotalsecs - start
]


もうなりふり構っていられないので、判定ループもドット数(size)の3分の1程度の最大33回にして、さらにこの範囲での上下対称を利用して下半分も同時描画にしています。これでなんとか 9000秒 = 2.5時間程度で描き終わるようにできました。


さらに画面を 赤くする 消すと3倍くらい速くなるという情報が件のアルト実機でのマンデルブロ描画の続報にあったので、どうやらそれっぽい UserView>>#displayoffwhile⦂ を見つけて使ってみたところ、ほんとに速くなりました。

http://squab.no-ip.com/collab/uploads/mandelbrot10.png


まあ、描いている途中を見たいところもあるので微妙ですが。^^;


ということで、同シリーズはこれにておしまい。マンデルブロ集合はもうしばらく見たくないです。w



追記
id:squeaker さんからコメントをいただいたので、Lively Kernel 上にリバイブされた Smalltalk-78 でも試してみました。Smalltalk-78 はノートテイカー(NoteTaker)と呼ばれる 8086を搭載した可搬式 PC 試作機向けに機能を削減した Smalltalk-76 です。

ノートテイカーは、アルトのパワーアップ版のドラド(Dorado)に対し、小型化の方向でダイナブックに一歩近づいたアルト後継機に位置づけられるマシンで、後の有名なオズボーン1の元ネタでもあります(タッチパネルを装備したりバッテリー駆動が可能など、オズボーン1よりずっと高機能です^^;)。

前述エミュレーターは Web アプリフレームワークの Lively Kernel(Lively Web)上にノートテイカーのエミュを構築し、その上で Smalltalk-78 を動作させています。

JS で実装されているので個人的には Smalltalk ゆかりの高速化技術で作られた V8 エンジンをを搭載している Chrome を推奨しています。


http://squab.no-ip.com/collab/uploads/mandelbrot12.png

| size half ori turtle limit start x y cre cim zre zim zre2 zim2 count [
   size ← 101.
   half ← size/2.
   ori ← Rectangle new fromuser origin.
   (ori extent: size asPoint) outline; clear: black.
   turtle ← Turtle init.
   limit ← size/3.
   start ← user ticks.
   for⦂ y from: (0 to: half) do⦂ [
      for⦂ x from: (0 to: size-1) do⦂ [
         cre ← x asFloat - half / half - 0.5.
         cim ← y asFloat - half / half.
         zre ← zim ← zre2 ← zim2 ← 0.0.
         count ← 1.
         while⦂ (count ≤ limit and⦂ zre2 + zim2 < 4.0) do⦂ [
            zim ← 2.0 * zre * zim + cim.
            zre ← zre2 - zim2 + cre.
            zim2 ← zim * zim.
            zre2 ← zre * zre.
            count ← count + 1
         ].
         [count > limit ⇒ [turtle color: black] turtle color: white].
         turtle penup; place: x + ori x ⌾ (y + ori y); pendn; go: 0.
         turtle penup; place: x + ori x ⌾ (size - y - 1 + ori y); pendn; go: 0
      ]
   ].
   (user ticks - start) asFloat / 1000
]


こちらは ContrAlto と違ってコピペでコードを貼り付けできる(必要なら環境からコードをコピペで持ち出すこともできる)のが楽でいいですね。^^;

手入力したい場合は、オープンコロンは : の2連続 :: 、ポイント記号はそのまま @ 、小なりイコールは <= 、〜ならばは => で入力できます。


ちょっと手直してして動かしてみたところ 100×100ドット、最大判定ループ33回で 85秒ほどでした。速い!


これなら最初の素朴な実装も待てる時間で動くのでは?と同様の条件で試してみたところ、驚きの95秒。対称性を利用していないことを考えるとこちらの方が速いのかもしれません。すばらしいですね。

http://squab.no-ip.com/collab/uploads/mandelbrot13.png

| size half origin turtle limit start x y c z count zsquared [
   size ← 101.
   half ← size/2.
   origin ← Rectangle new fromuser origin.
   (origin - 1 extent: size⌾size + 2) outline; clear: black.
   turtle ← Turtle init.
   limit ← size/3.
   start ← user ticks.
   for⦂ y from: (0 to: size-1) do⦂ [
      for⦂ x from: (0 to: size-1) do⦂ [
         c ← x asFloat ⌾ y asFloat - half / half - (0.5⌾0).
         z ← 0.0⌾0.0.
         count ← 0.
         while⦂ ((count ← count + 1) ≤ limit and⦂ z length < 2) do⦂ [
            zsquared ← z x * z x - (z y * z y) ⌾ (2.0 * z x * z y).
            z ← zsquared + c
         ].
         turtle color: [count > limit ⇒ [black] white].
         turtle penup; place: x⌾y + origin; pendn; go: 0
      ]
   ].
   (user ticks - start) asFloat / 1000
]

Squeak Smalltalk でマンデルブロ集合 番外編(Squeak Etoys 毛玉版)

Squeak Etoys に組み込みの id:squeakerさんの毛玉(Kedama)を使って書いてみました。基本的に その3 などでやっているように実部と虚部に分けて計算する実装の移植です。毛玉は、端的に言うと LOGO の後継の StarLogo の流れを汲む並行処理版タートルグラフィックスシステムで、複数のタートルを同時に動かすことができるようになっています。

毛玉では複数のブリード(タートルの種類)を使いわけてグループごとに振る舞いを変えることができますが、今回は1種類 Breed1 しか使っていないのでこれはすなわちタートル(の振る舞い)そのものと考えて大丈夫です。

タートルというとその軌跡でグラフィックを描くイメージですが、ここでのタートルはあらかじめ 100×100 = 10000マスあるパッチ変数(セルのようなもの)に1匹ずつ割り当てておきそこからは動きません。では何をしているかというと、各々の複素平面内での位置(cre、cim)から z ^ 2 + c を繰り返し計算し、発散しない限りパッチ変数の数を減じてゆくよう振る舞わせています。発散したと判断されたときのパッチ変数の値がそのままグレイの点として描画に反映されます(早く発散してしまえば白のまま、発散しなければ黒に近づく)。

なお、Squeak EToys の四則演算は Smalltalk と同じく乗除優先がないのに加え、Smalltalk(ただし -76 以降)とは逆の右結合という特殊な振る舞いをするので注意が必要です。正しい演算結果を得るにはちょっとした工夫が必要になります。


毛玉についてはこちらの文書が一番詳しく書かれていると思います。

http://squab.no-ip.com/collab/uploads/mandelbrot08.png

Squeak Smalltalk でマンデルブロ集合 その3(1トゥート版)

マストドンでは1トゥートが 500文字までで、そのインスタンスのひとつの Qiitadon ではコードブロックを指定できることから、短めのプログラムならシンタックスハイライトを使ってトゥートすることが可能です。id:squeakerさんが提示された配列を積算する方法(特にコメントアウトされた素朴な実装の方)を見ていて、Squeak Smalltalk の持つ配列同士の演算を用いれば短く書くこともできるのではないかと思いついたのでトライしてみました。

http://squab.no-ip.com/collab/uploads/mandelbrot07.png


実はちょっと間違いがあって訂正済みの版がこちら。

|s h r x y c q m f i b|
s:=300.
h:=s//2.
s:=s roundUpTo:32.
r:=(0to:s-1)-h/h.
x:=(Array new:s withAll:r)concatenation.
y:=r gather:[:v|Array new:s withAll:v].
c:={x-0.5. y-0.0}.
q:=[:p||re im|re:=p at:1. im:=p at:2. {re*re-(im*im). re*im*2}].
m:=(1to:100)inject:c*0into:[:z :j|(q value:z)+c].
f:=Form extent:(h*2)asPoint.
i:=[:w|Integer readFrom:(w collect:[:v|(v<4)asBit asHexDigit])readStream base:2].
b:=(m*m)sum groupsOf:32atATimeCollect:i.
f bits:(b as:Bitmap);display


そしてスペース等の省略を戻し、少しだけ速度を意識して FloatArray 等若干の変更や拡張を施したのがこちらです。

| size half range xs ys cs squared time map form asInt32 bits |
size := 200.
half := size//2.
size := size roundUpTo: 32.
range :=  (0 to: size-1) - half / half.
xs := (Array new: size withAll: range) concatenation asFloatArray.
ys := (range gather: [:x | Array new: size withAll: x]) asFloatArray.
cs := {xs - 0.5. ys}.
squared := [:pair | {pair first squared - pair second squared. pair first * pair second * 2}].
time := [map := (1 to: 100) inject: cs * 0 into: [:zs :idx | (squared value: zs) + cs]] timeToRun.
form := Form extent: (half * 2) asPoint.
asInt32 := [:vs | Integer readFrom: (vs collect: [:v | (v < 4) asBit asHexDigit]) readStream base: 2].
bits := (map * map) sum groupsOf: 32 atATimeCollect: asInt32.
form bits: (bits as: Bitmap); display.
time. "=> 3033 "


ビットマップを生成してフォームに食わせているところがこだわりだったのですが、普通にピクセルごとに値を置いた方がずっと短く書けるのでなんだかなーと言う感じですね。^^;

|s h r x y c q m f|
s:=300.
h:=s//2.
r:=(0to:s-1)-h/h.
x:=(Array new:s withAll:r)concatenation.
y:=r gather:[:v|Array new:s withAll:v].
c:={x-0.5. y-0.0}.
q:=[:p||re im|re:=p at:1. im:=p at:2. {re*re-(im*im). re*im*2}].
m:=(1to:100)inject:c*0into:[:z :j|(q value:z)+c].
f:=Form extent:(h*2)asPoint.
(m*m)sum doWithIndex:[:v :i|f pixelValueAt:i\\s@(i//s)put:(v<4)asBit]. 
f display


ついでと言ってはなんですが、グレイスケール版にも挑戦してみました。もし #< や #asBit などが加減乗除などの二項セレクターと同様に Colletion のダブルディスパッチに対応していたら map := map + (zs squared sum asArray < 4) asBit などと速度はともかくもっと簡潔に書けそうなものなのですが、現状ではかなり見栄えの悪いものになってしまっていて残念です。

| size half range xs ys cs zs squared time map form bits |
size := 300.
half := size//2.
range :=  (0 to: size-1) - half / half * 1.3.
xs := (Array new: size withAll: range) concatenation asFloatArray.
ys := (range gather: [:x | Array new: size withAll: x]) asFloatArray.
cs := {xs - 0.75. ys}.
zs := cs * 0.
map := Array new: xs size withAll: 0.
squared := [:pair | {pair first squared - pair second squared. pair first * pair second * 2}].
time := [
   100 timesRepeat: [
      zs := squared value: zs + cs.
      map := map + (zs squared sum asArray collect: [:v | (v < 4) asBit]).
   ]
] timeToRun.
form := Form extent: (half * 2) asPoint depth: 32.
bits := map collect: [:v | (Color gray: 1- (v/100) sqrt) pixelWordForDepth: 32].
form bits: (bits as: Bitmap); display.
time. "=> 11591 "

http://squab.no-ip.com/collab/uploads/mandelbrot06.png


追記
最後に、速度を気にして FloatArray を使うなどしないのであれば、実部と虚部それぞれに配列を用意せずとも複素数の配列ひとつで済ませてもよいのではないかと書いてみたらこんな感じになりました。

| size half range cs form map time zs |
size := 300.
half := size//2.
range := (0 to: size-1) - half / half * 1.3.
cs := ((Array new: size withAll: range) + (range collect: #i) - 0.75) concatenation.
zs := cs * 0.
map := cs abs * 0.
time := [
   100 timesRepeat: [
      zs := zs squared + cs.
      map := map + (zs abs collect: [:v | (v < 2) asBit]).
   ]
] timeToRun.
form := Form extent: (half * 2) asPoint depth: 32.
map doWithIndex: [:v :idx | form colorAt: idx\\size@(idx//size) put: (Color gray: 1- (v/100) sqrt)].
form display.
time. "=> 15789 "

Squeak Smalltalk でマンデルブロ集合 その2(id:squeakerさん版)

コメントでいただいた id:squeakerさんのコードに僭越ながら少し手を入れたものを。FlaotArray>>#*= とか知らなくてなんじゃこれ?!となったのは内緒です。^^; Float nan や Float infinity の振る舞いを利用するのは面白いですね。

| size half zREs zIMs prevREs prevIMs cREs cIMs idx time |

size := 600.
half := size / 2.

zREs := FloatArray new: size * size.
zIMs := FloatArray new: size * size.

prevREs := FloatArray new: size * size.
prevIMs := FloatArray new: size * size.

cREs := FloatArray new: size * size.
cIMs := FloatArray new: size * size.

idx := 1.
half negated to: half - 1 do: [:y |
   half negated to: half - 1 do: [:x |
      cREs at: idx put: x / half.
      cIMs at: idx put: y / half.
      idx := idx + 1
   ]
].

cREs -= 0.5.

time := [
   1 to: 100 do: [:z |
      zREs replaceFrom: 1 to: zREs size with: prevREs startingAt: 1.
      zIMs replaceFrom: 1 to: zIMs size with: prevIMs startingAt: 1.

      zREs *= prevREs -= (prevIMs *= prevIMs) += cREs.
      zIMs *= prevREs *= 2.0 += cIMs.

      {prevREs. prevIMs} elementsExchangeIdentityWith: {zREs. zIMs}.

      "prevREs := zREs.
      zREs := (zREs * zREs) - (zIMs * zIMs) + cREs.
      zIMs := (zIMs * prevREs) + (prevREs * zIMs) + cIMs."

   ]
] timeToRun.

Display restoreAfter: [
   idx := 1.
   0 to: size - 1 do: [:y |
      0 to: size - 1 do: [:x |
         | re im |
         re := prevREs at: idx.
         im := prevIMs at: idx.
         idx := idx + 1.
         ((re isNaN not and: [re isInfinite not]) and: [im isNaN not and: [im isInfinite not]])
            ifTrue: [Display colorAt: x@y put: Color black]
            ifFalse: [Display colorAt: x@y put: Color white]
      ]
   ].
   [Sensor anyButtonPressed] whileFalse
].

time "=> 16442 vs 25594 "

http://squab.no-ip.com/collab/uploads/mandelbrot04.png

Squeak Smalltalk でマンデルブロ集合

こちらの件のレストアしたアルト実機で BCPL で記述したマンデルブロ集合を実行してみたら1時間かかったという話を読んでいて、そういえば自分でマンデルブロ集合を描いてみたことがなかったなぁ…と気付いたのでさっそく書いてみました。

本当は、かなり以前に Smalltalk-80 で見た実装(ウインドウに表示して、一部を矩形選択するとその部分が新しいウインドウとして表示される)を作ってみたかったのですが、勢いで書けてワークスペースでさくっと実行できる簡単なもので済ませてしまいました。駄目ですね…。^^;

Display restoreAfter: [
   | limit dispRect ratio complexArea mandelbrot newRect scale |

   limit := 128.
   dispRect := Rectangle center: Display center extent: Display extent // 2.
   ratio := dispRect extent / dispRect height.
   complexArea := -1.0@0.0 - (ratio * 1.4) extent: ratio * 2.8.

   scale := [:pt |
      complexArea topLeft + (((pt x - dispRect left) * complexArea width / dispRect width)
         @ ((pt y - dispRect top) * complexArea height / dispRect height))].

   mandelbrot := [:c |
      | z count |
      z := 0.
      count := 0.
      [z squared abs < 4 and: [count < limit]] whileTrue: [
         z := z squared + c.
         count := count + 1
      ].
      (count / limit) sqrt
   ].

   Display fillWhite: dispRect.

   [:exit | [
      dispRect top to: dispRect bottom - 1 do: [:y | dispRect left to: dispRect right - 1 do: [:x |
         | pos color |
         pos := scale value: x@y.
         color := Color h: (mandelbrot value: pos x + pos y i) * 360 + 120 s: 1.0 v: 1.0.
         Display colorAt: x@y put: color.
         Sensor anyButtonPressed ifTrue: [exit value]
      ]].

      newRect := Rectangle fromUser.
      newRect area > 0 ifFalse: [exit value] ifTrue: [
         | center delta |
         center := newRect center.
         delta := dispRect extent * (newRect width / dispRect width max: newRect height / dispRect height) / 2.
         complexArea := (scale value: center - delta) corner: (scale value: center + delta).
      ]
   ] repeat] valueWithExit
]


Squeak のワークペース(デスクトップメニュー or Tools → Workspace )にペースト(alt/cmd + v)して改めて全選択(alt/cmd + a)後、do it(alt/cmd + d)で実行できます。

http://squab.no-ip.com/collab/uploads/mandelbrot01.png


一部を矩形選択するとその部分を拡大して再描画します。枠外を大きく選択すると縮小もできます。選択をせずクリックすると終了です。

http://squab.no-ip.com/collab/uploads/mandelbrot02.png


Pharo の Playground でも動かせますが、なんとけしからんことに Squeak で組み込みだった Complex が外されてモジュールに追い出されてしまっているので事前にインストールしておく必要があります(デスクトップメニュー → Tools → Catalog Browser → complex などと入力して Complex を右クリック → install stable version )。

http://squab.no-ip.com/collab/uploads/mandelbrot03.png


もうひとつ Pharo では描画後の拡大域選択操作の前にアクティブウインドウの再描画がされてしまうので、Playground ウインドウはあらかじめ端によけておかないといけません。ご注意あれかし。

型クラスの現在のところの理解を Squeak Smalltalk で表現してみる


ここ数日で、Scala の implicit parameter がどうやって型クラスっぽいことを実現しているかというのが分かったような気になってきたのと、型クラスが「状態を扱わないメソッドの集合」であるということを聞いて「それってまさにトレイトそのもの(ただし Scala のそれではなくシェルリの)じゃないか!」とも思ったので、Squeak(あるいは Pharo)のトレイトを使って型クラスを表現してみるとどうなるか試して遊んでみました。もとより動的型の Smalltalk で何ができるわけでもないので、あくまで雰囲気だけですが。


以降に示す各式は Squeak の Workspace に適宜貼り付けて(一挙ではなく)順に評価( do it、あるいは結果が欲しければ print it )すると実行できます。

Pharo の Playground でもいちおう動作しますが、Pharo にはなぜか #uses: がないので、あらかじめ次式を評価して Squeak 同様の #uses: を追加しておく必要があります。

ClassDescription compile: 'uses: trait self setTraitComposition: trait asTraitComposition'


あと念のため、Smalltalk環境(IDEモドキ)の最小限の操作だけで遊べるように、クラスやトレイトの定義やそれらへのメソッドの追加はすべて式で、例えば

(トレイトの定義の式) compile: 'メソッドの定義'

というように表現しています。本来であれば、クラスブラウザなどの GUI ツールを用いるのがデフォ(このため GNU Smalltalk などの特殊な処理系を除き、Smalltalk にはクラスやメソッド定義のための構文が無い!)なのでこの点もどうぞあしからず。


まず型クラス Eq を模したトレイト TCEq として定義します。ちなみに Eq の定義は Haskell ではこうです。(Hugs.Prelude から抜粋。下の Ord も同じ)

class Eq a where
    (==), (/=) :: a -> a -> Bool

    -- Minimal complete definition: (==) or (/=)
    x == y      = not (x/=y)
    x /= y      = not (x==y)


この遊びでは既存のメソッドとかぶらないように EQ: NEQ: などとしました。

"type class Eq"
(Trait named: #TCEq uses: #() category: 'TypeClasses-Simulation')
compile: 'EQ: other
   ^(self NEQ: other) not';
compile: 'NEQ: other
   ^(self EQ: other) not'.


次に同じく型クラス Ord を模したトレイト TCOrd を定義します。Haskell の Ord の定義はこちら。

class (Eq a) => Ord a where
    compare                :: a -> a -> Ordering
    (<), (<=), (>=), (>)   :: a -> a -> Bool
    max, min               :: a -> a -> a

    -- Minimal complete definition: (&lt;=) or compare
    -- using compare can be more efficient for complex types
    compare x y | x==y      = EQ
		| x<=y      = LT
		| otherwise = GT

    x <= y                  = compare x y /= GT
    x <  y                  = compare x y == LT
    x >= y                  = compare x y /= LT
    x >  y                  = compare x y == GT

    max x y   | x <= y      = y
	      | otherwise   = x
    min x y   | x <= y      = x
	      | otherwise   = y


Ord は Eq を継承しているので TCOrd も TCEq を #uses: します。

"type class Eq => Ord"
(Trait named: #TCOrd uses: TCEq category: 'TypeClasses-Simulation')
compile: 'CMP: other
   ^true caseOf: {
      [self EQ: other] -> [#EQ].
      [self LE: other] -> [#LT]
   } otherwise: [#GT]';
compile: 'LE: other
   ^(self CMP: other) ~= #GT';
compile: 'LT: other
   ^(self CMP: other) == #LT';
compile: 'GE: other
   ^(self CMP: other) ~= #LT';
compile: 'GT: other
   ^(self CMP: other) == #GT';
compile: 'MAX: other
   ^(self LE: other) ifTrue: [other] ifFalse: [self]';
compile: 'MIN: other
   ^(self LE: other) ifTrue: [self] ifFalse: [other]'.


次にインスタンス Ord Int に相当するトレイト TOrdInteger を定義します。型クラスとそのインスタンスの関係からこれはクラスで表現したほうが相応しいかとも思ったのですが、後のことを簡単に済ませたいのでここはあえてトレイトにします。

型クラス Ord のインスタンスは #CMP: か #LE: を自前で用意する必要があると同時に、Ord は Eq のサブクラスでもあることから #EQ: か #NEQ: も同様に自前で用意する必要があります。ここではそれぞれ #LE: と #EQ: を定義しました。

"type class instance Ord Integer"
(Trait named: #TOrdInteger uses: TCOrd category: 'TypeClasses-Simulation')
compile: 'EQ: other
   ^self = other';
compile: 'LE: other
   ^self <= other'.


前述の“後のこと”こと、型クラスを機能させるための“マジック”については、ここでは簡単のためトレイトを #uses: することで代用しました。ちなみに Haskell だとここで暗黙の引数にメソッド辞書を、Scala なら辞書代わりのオブジェクトを渡すよう裏で細工が(ただしこれらの言語ではコンパイル時に)なされます。

Integer uses: TOrdInteger. "use magic"


では準備が整いましたので動作の確認をします。

3 EQ: 3. "=> true "
3 EQ: 4. "=> false "

3 NEQ: 3. "=> false "
3 NEQ: 4. "=> true "

3 CMP: 3. "=> #EQ "
3 CMP: 4. "=> #LT "
4 CMP: 3. "=> #GT "

3 LE: 3. "=> true "
3 LE: 4. "=> true "
4 LE: 3. "=> false "

3 LT: 3. "=> false "
3 LT: 4. "=> true "
4 LT: 3. "=> false "

3 GE: 3. "=> true "
3 GE: 4. "=> false "
4 GE: 3. "=> true "

3 GT: 3. "=> false "
3 GT: 4. "=> false "
4 GT: 3. "=> true "

3 MAX: 3. "=> 3 "
3 MAX: 4. "=> 4 "
4 MAX: 3. "=> 4 "

3 MIN: 3. "=> 3 "
3 MIN: 4. "=> 3 "
4 MIN: 3. "=> 3 "

うまく動いていますね。


ついでに #MEMBER: や #SORT も定義しようかと思ったのですが、当然のことながら Smalltalk でレシーバーに Eq a => [a] や Ord a => [a] といった縛りは設けられないためやむなく Array に定義するしかなく、ここまでそれっぽく動いていたのと比べるとかなり興ざめです。

Array
compile: 'MEMBER: y
   self ifEmpty: [^false].
   ^(self first EQ: y) or: [self allButFirst MEMBER: y]';
compile: 'SORT
   | pivot |
   self ifEmpty: [^self].
   pivot := self middle.
   ^(self select: [:x | x LT: pivot]), {pivot}, (self select: [:x | x GT: pivot])'.
#(1 2 3) MEMBER: 3. "=> true "
#(3 2 1) SORT. "=> #(1 2 3) "


次に Ord a => Ord [a] に対応するインスタンスを作りたかったのですがやはり無理なので Ord [Int] 相当で我慢します。トレイト OrdIntegerArray を作り同様のマジックを IntegerArray に使ってみましょう。

"type class instance Ord [Int]"
(Trait named: #TOrdIntegerArray uses: TCOrd category: 'TypeClasses-Simulation')
compile: 'EQ: other
   (self isEmpty and: [other isEmpty]) ifTrue: [^true].
   (self isEmpty or: [other isEmpty]) ifTrue: [^false].
   ^(self first EQ: other first) and: [self allButFirst EQ: other allButFirst]';
compile: 'LE: other
   self ifEmpty: [^true].
   other ifEmpty: [^false].
   ^(self first LT: other first) or: [
		(self first EQ: other first) and: [self allButFirst LE: other allButFirst]]'.
IntegerArray uses: TOrdIntegerArray. "use magic"


これで、IntegerArray 同士の等価や大小比較が可能になります。以下、動作確認です。

#(1 2 3) asIntegerArray EQ: #(1 2 3) asIntegerArray. "=> true "
#(1 2 3) asIntegerArray EQ: #(1 3 2) asIntegerArray. "=> false "

#(1 2 3) asIntegerArray NEQ: #(1 2 3) asIntegerArray. "=> false "
#(1 2 3) asIntegerArray NEQ: #(1 3 2) asIntegerArray. "=> true "

#(1 2 3) asIntegerArray CMP: #(1 2 3) asIntegerArray. "=> #EQ "
#(1 2 3) asIntegerArray CMP: #(1 3 2) asIntegerArray. "=> #LT "
#(1 3 2) asIntegerArray CMP: #(1 2 3) asIntegerArray. "=> #GT "

#(1 2 3) asIntegerArray LE: #(1 2 3) asIntegerArray. "=> true "
#(1 2 3) asIntegerArray LE: #(1 3 2) asIntegerArray. "=> true "
#(1 3 2) asIntegerArray LE: #(1 2 3) asIntegerArray. "=> false "

#(1 2 3) asIntegerArray LT: #(1 2 3) asIntegerArray. "=> false "
#(1 2 3) asIntegerArray LT: #(1 3 2) asIntegerArray. "=> true "
#(1 3 2) asIntegerArray LT: #(1 2 3) asIntegerArray. "=> false "

#(1 2 3) asIntegerArray GE: #(1 2 3) asIntegerArray. "=> true "
#(1 2 3) asIntegerArray GE: #(1 3 2) asIntegerArray. "=> false "
#(1 3 2) asIntegerArray GE: #(1 2 3) asIntegerArray. "=> true "

#(1 2 3) asIntegerArray GT: #(1 2 3) asIntegerArray. "=> false "
#(1 2 3) asIntegerArray GT: #(1 3 2) asIntegerArray. "=> false "
#(1 3 2) asIntegerArray GT: #(1 2 3) asIntegerArray. "=> true "

#(1 2 3) asIntegerArray MAX: #(1 2 3) asIntegerArray. "=> an IntegerArray(1 2 3) "
#(1 2 3) asIntegerArray MAX: #(1 3 2) asIntegerArray. "=> an IntegerArray(1 3 2) "
#(1 3 2) asIntegerArray MAX: #(1 2 3) asIntegerArray. "=> an IntegerArray(1 3 2) "

#(1 2 3) asIntegerArray MIN: #(1 2 3) asIntegerArray. "=> an IntegerArray(1 2 3) "
#(1 2 3) asIntegerArray MIN: #(1 3 2) asIntegerArray. "=> an IntegerArray(1 2 3) "
#(1 3 2) asIntegerArray MIN: #(1 2 3) asIntegerArray. "=> an IntegerArray(1 2 3) "


まったく面白みはないですが、いちおう #MEMBER:、#SORT も動きます。

{#(1 3 2) asIntegerArray. #(1 2 3) asIntegerArray. #(2 3 1) asIntegerArray} MEMBER: #(1 3 2) asIntegerArray. "=> true "
{#(1 3 2) asIntegerArray. #(1 2 3) asIntegerArray. #(2 3 1) asIntegerArray} SORT.
"=> {an IntegerArray(1 2 3) . an IntegerArray(1 3 2) . an IntegerArray(2 3 1)} "


型クラスの肝である“マジック”の部分、つまり既存の定義をいじらずに拡張できる細工をどう裏で実現するかはいろいろあっても良さそうです。また、エンティティとしての型クラスが、デフォルト実装を持てるインターフェイスや(Scalaのではなくシェルリの)トレイトが機能面で共有する類似性に個人的にはとても興味惹かれます。


参考:

〜ect:で終わるセレクター(Rubyで言うところの〜ect系のメソッド名)にはどんなものがあるか、あらためてSqueak Smalltalkで調べてみた


アーロ・ガスリーの「アリスのレストラン」の歌詞にインスパイアされて Smalltalk-80 から使われ始めたとされる collect: 、select: 、inject:into: など Ruby で言うところSmalltalk 由来の 〜ect系のメソッド名(Smalltalk では「メッセージセレクター」あるいは単に「セレクター」)ですが、そういえば当該歌詞にも登場する inspect も広い意味では 〜ect系と考えてよさそうだな、他にも何かないのかな…とふと気になったので、まだ知らない便利な 〜ect:系セレクターの発見もあるかも!と改めて調べてみました。

結果としては、既に把握している collect:、select:、reject:、detect:、inject:into: とその変種の他には目新しいものは見つからなかったわけですが(当然と言えば当然か…)、せっかくなので使った式と結果をメモとして下に残しておきます。^^;


余談ですが、件の歌詞には inject、inspect、detect、select、inspect は登場するものの、collect や reject は見当たらない(では、後者はさておき collect: はどこから?)のもちょっとだけ気になります。



▼ コレクションクラスで使われている ect: を含むセレクター群

(Array streamContents: [:ss |
   (Collection withAllSubclasses remove: Matrix; yourself) do: [:class |
      ss nextPutAll: (
         class selectors select: [:sel | (sel includesSubString: 'ect:')
            and: [(sel asLowercase includesSubString: 'object') not]])
   ]
]) asSet

Matrix はちょっと特殊なので除きました。

"=> a Set(#collect:thenSelect: #collect:from:to: #pairsCollect: #collect:into: #select:thenCollect: 
#collect: #detect:ifNone: #overlappingPairsCollect: #groupsOf:atATimeCollect: #inject:into: 
#select:thenDo: #withIndexCollect: #select: #collect:as: #detect:ifFound:ifNone: #collect:thenDo: 
#traitsCollect: #valuesCollect: #reject: #detect: #associationsSelect: #with:collect: 
#reject:thenDo: #regex:matchesCollect:) "


▼ 〜ect 的なセレクターには他にどんなものがあるのか?

(Array streamContents: [:ss |
   SystemNavigation default allBehaviorsDo: [:class |
      ss nextPutAll: (
         class selectors select: [:sel | (sel includesSubString: 'ect')
            and: [#(object project rect expect aspect effect connect intersect 
                  perfect subject selection ector section defect dissect infect 
                  protect dialect collect select inject reject detect) 
               noneSatisfy: [:NG | sel asLowercase includesSubString: NG]]
         ])
   ]
]) asSet

コレクションの〜ect系と、ectを含む単語を除いて集計してみましたが、実質 inpect しか見つかりませんでした。

"=>  a Set(#inspectIt: #inspectPointers #inspectCurrentStack #inspectOwnerChain 
#test06InspectIt #inspect: #inspectForm #inspectCurrentBackground #inspectInstances 
#inspectOnCount: #inspectModel #inspectIt #inspectProcess #inspectCurrentCard #basicInspect: 
#inspectWorkingCopy #inspectMethod #inspectArgumentsPlayerInMorphic: #basicInspect #inspect 
#inspectWorldModel #inspectInMorphic: #inspectViewee #inspectWithLabel: #inspectUntilCount: 
#inspectAt:event: #inspectOnce #inspectChangeSet #inspect:label: #inspectParameters 
#inspectInMorphic #inspectTestVars #inspectBasic #inspectContext #inspectSubInstances 
#inspectReceiver #inspectFirstSubView #inspectAllInstances #smallInspectItIconContents 
#inspectPreferences #inspectView #inspectKey #inspectElement #inspectFormDictionary 
#inspectBindings #inspectMember #inspectIt:result: #smallInspectItIcon #doExpiredInspectCount)"