[Scheme][Nu] 第1回 Scheme コードバトンに参加したのですが・・・・

第1回 Scheme コードバトンに Nu で参加したのですが、ぜんぜん別ものになってしまったのでバトンからは離脱しましたが、成果は GitHub に上げておきました。

上の画像のような GUI版になっています。なぜ別のものになったかというと

Nu は Lispをベースとしていますが、List処理機能は低く最近の Scheme からコードを持ってくるには、あまりにも非力
Nu はオブジェクト指向言語なので (car e) はではなく (e car) と記述します、もちろん car 関数等も用意されていて (car e) とも書けるのですが、他の部分との整合性を考えると (e car) と書きたくなります ^^)
Nu の一番の長所は Mac の GUIアプリ(Cocoa) が書ける事です！ S式で GUIアプリを書いてみたくなった。

コードの説明

まずは、単語帳を扱う Words クラス、ファイルから単語帳を読んだり、めくったり、正解・不正解を記録したり、それをファイルに書いたりするクラスです。

Nu はUTF-8 を扱えるのですが S式レベルで出力するとおかしな動きをします、それをカバーする為に writeToFile:メソッドは変な事になっています。入出力は当然 Cocoa API を使ってます。リストのソートはリストから配列に変換してソートしリストに戻してます ^^;

(class Words is NSObject
    (ivars)
    (- initWithFile:file is
        (let ((p ((NuParser alloc) init))
              (s (NSString stringWithContentsOfFile:file encoding:4 error:nil))
              (l nil))
             (super init)
             (set l ((p parse:s) cdr))
             (set @words (l map:(do (e) (if (== (e length) 2) (append e '(0 0)) (else e)))))
             (set @top @words)
             self))

     (+ wordsWithResorceFile:file ofType:ext is
         ((Words alloc) initWithFile:((NSBundle mainBundle) pathForResource:file ofType:ext)))
              
     (- writeToFile:file is
         (let ((s "")
               (q (NSString stringWithCharacter:34)))
              (@words each:(do (e) (s appendString:
                  "(#{(e car)} #{q}#{(e cadr)}#{q} #{(e caddr)} #{(e cadddr)})#{(NSString carriageReturn)}")))
              (s writeToFile:file atomically:1 encoding:4 error:nil)))

     (- writeToResorceFile:file ofType:ext is
         (self writeToFile:((NSBundle mainBundle) pathForResource:file ofType:ext)))

     (- sortByNg is 
         (set @words (((@words array) sortedArrayUsingBlock:(do (x y) ((y cadddr) compare:(x cadddr))))
                        list))
         (set @top @words))

     (- isEnd is (== @top ()))
     (- top is  (@top car))
     (- next is (set @top (cdr @top)))
     (- setOk is ((@top car) setCaddr:(+ 1 ((@top car) caddr))))
     (- setNg is ((@top car) setCadddr:(+ 1 ((@top car) cadddr))))

     (- value is  @words)
)

GUIをコントロールしている部分、大部分はGUIの組み立てです。イベント処理を無理矢理に継続を使ってまとめています ^^);

(function standard-cocoa-button (frame)
     (((NSButton alloc) initWithFrame:frame)
      set: (bezelStyle:NSRoundedBezelStyle)))

(function standard-cocoa-textfield (frame)
     (((NSTextField alloc) initWithFrame:frame)
      set: (bezeled:0 editable:0 alignment:NSLeftTextAlignment drawsBackground:1)))

(macro initEvent (*body)
    `(progn (set @eventCountinuation ((NSMutableDictionary alloc) init))
            ,@*body))

(macro doEvent (name *params)
    `((@eventCountinuation valueForKey:,(name stringValue)) ,@*params))

(macro whenEvent (name args *body)
    `(@eventCountinuation setValue:(do ,args ,@*body) forKey:,(name stringValue)))


(class WordsAppWindowController is NSObject
     (ivars)
     
     (- init is
          (super init)
          (let (w ((NSWindow alloc)
                   initWithContentRect: '(300 200 420 120)
                   styleMask: (+ NSTitledWindowMask NSClosableWindowMask NSMiniaturizableWindowMask)
                   backing: NSBackingStoreBuffered
                   defer: 0))
               (w set: (title:"Words"))
               (let (v ((NSView alloc) initWithFrame:(w frame)))
                    (let (b (standard-cocoa-button '(280 60 116 32)))
                         (b set: (title: "Check" target: self action:"check:"))
                         (v addSubview:b)
                         (set @checkButton b))
                    (let (b (standard-cocoa-button '(280 20 58 32)))
                         (b set: (title: "Yes" target: self action:"yes:"))
			 (b setEnabled:nil)
                         (v addSubview:b)
                         (set @yesButton b))
                    (let (b (standard-cocoa-button '(340 20 58 32)))
                         (b set: (title: "No" target: self action:"no:"))
			 (b setEnabled:nil)
                         (v addSubview:b)
                         (set @noButton b))
                    (let (t (standard-cocoa-textfield '(50 66 200 22)))
		    	 (t setStringValue:"")
                         (v addSubview:t)
                         (set @englishText t))
                    (let (t (standard-cocoa-textfield '(50 26 200 22)))
		    	 (t setStringValue:"")
                         (v addSubview:t)
                         (set @japaneseText t))
                    (w setContentView:v))
               (w center)
               (set @window w)
               (w makeKeyAndOrderFront:self))
          (self procedure)
          self)

     
     (- check:sender is (doEvent checkButtonPush))

     (- yes:sender is (doEvent answerButtonPush t))

     (- no:sender is (doEvent answerButtonPush nil))
      	
     (- procedure is
        (let ((words (Words wordsWithResorceFile:"words" ofType:"txt")))

             (initEvent
                 (words sortByNg)
                 (@englishText setStringValue:(((words top) car) stringValue)))
             
             (whenEvent checkButtonPush () 
          	(@japaneseText setStringValue:(((words top) cadr) stringValue))
     	        (@yesButton setEnabled:t)
     	        (@noButton  setEnabled:t))
             
             (whenEvent answerButtonPush (yn)
                (if yn (then (words setOk)) (else (words setNg)))
                (words writeToResorceFile:"words" ofType:"txt")
          	    (words next)
          	    (if (words isEnd)
          	        (then
          	            (self terminate:nil))
          	        (else 
                            (@englishText setStringValue:(((words top) car) stringValue))
          	            (@japaneseText setStringValue:"")
          	            (@yesButton setEnabled:nil)
          	            (@noButton  setEnabled:nil))))))
)