カテゴリー: Scheme

リスト（配列）の中で隣り合う同じ値をグループ化する(2)

こないだのやつを Scheme と Haskell でやってみた。

まずは Scheme 版。

(define adjacent-group
  (lambda (lis)
    (let loop ((l (cdr lis)) (c (car lis)) (r (cons (list (car lis)) '())))
      (if (null? l)
          (reverse (map reverse r))
          (if (= (car l) c)
              (loop (cdr l) c (cons (cons (car l) (car r)) (cdr r)))
              (loop (cdr l) (car l) (cons (list (car l)) r)))))))

(print (adjacent-group '(1 1 2 2 3 1 1)))
^o^ >gosh adjacent-group.scm
((1 1) (2 2) (3) (1 1))

基本的な考え方は、Ruby や Python のと同じ。ちょっと工夫したのは、先頭の要素を最初から結果のリストに入れたこと。これで分岐条件が１つ減った。
……のはいいんだけど、これって引数に空リストが来た時のことが考えられてないじゃないか。まあ、グループ化しようというんだから空リストは考えなくてもいいか……ホントか？

さて、Haskell 版。こっちはちゃんと空リストが来ても大丈夫（実行例は示さないけど）。

adjacentGroup :: [Int] -> [[Int]]
adjacentGroup [] = []
adjacentGroup (x:xs) = reverse $ map reverse $ foldl f [[x]] xs
  where
    f (y:ys) z = if head y == z
                 then (z:y):ys
                 else (z:[]):y:ys

main :: IO()
main = print $ adjacentGroup [1, 1, 2, 2, 3, 1, 1]
^o^ >runhaskell adjacentGroup.hs
[[1,1],[2,2],[3],[1,1]]

[追記](9/27)

Scheme 版を空リスト対応にした。分岐条件が１つ増えた。

(define adjacent-group
  (lambda (lis)
    (let loop ((l lis) (c (undefined)) (r '()))
      (if (null? l)
          (reverse (map reverse r))
          (cond
            ((undefined? c) (loop (cdr l) (car l) (cons (list (car l)) r)))
            ((= (car l) c) (loop (cdr l) c (cons (cons (car l) (car r)) (cdr r))))
            (else (loop (cdr l) (car l) (cons (list (car l)) r))))))))

(print (adjacent-group '(1 1 2 2 3 1 1)))
(print (adjacent-group '()))
^o^ >gosh adjacent-group2.scm
((1 1) (2 2) (3) (1 1))
()

[さらに追記](9/28)

分岐条件を工夫して2つに減らせた。cond じゃなく if になった。

(define adjacent-group
  (lambda (lis)
    (let loop ((l lis) (c (undefined)) (r '()))
      (if (null? l)
          (reverse (map reverse r))
          (if (and (not (undefined? c)) (= (car l) c))
              (loop (cdr l) c (cons (cons (car l) (car r)) (cdr r)))
              (loop (cdr l) (car l) (cons (list (car l)) r)))))))

(print (adjacent-group '(1 1 2 2 3 1 1)))
(print (adjacent-group '()))
^o^ > gosh adjacent-group3.scm
((1 1) (2 2) (3) (1 1))
()

Schemeで数値を文字列に変換するには

number->string 手続きが使える。このあいだ Look and Say 数列を作った時にはググっても何故か見つからなくて、先に見つかった write-to-string を使ったんだけど、number->string のほうが名前も自然だし短い。

gosh> number->string
#<subr number->string>
gosh> (number->string 123)
"123"
gosh> (number->string 3.14)
"3.14"

ちなみに、文字列を数値に変換するには string->number。

gosh> string->number
#<subr string->number>
gosh> (string->number "3.14")
3.14

Look and Say 数列

ちょっと面白いものを見つけた。

　cf. 「Haskell」で「Look and Say 数列」を生成してみた – Zodiacの黙示録

Look and Say 数列とは次のようなものらしい。

1 11 21 1211 111221 ...

ちょっと規則性が見いだせないが、

  1. 最初の項は「1」
  2. 次の項は直前の項を見る(look)。すると「1」個の「1」。
  3. なので「11」と言う(say)。
  4. さらに次の項は直前の項を見て、「2」個の「1」。
  5. なので「21」と言う。
  6. 以下繰り返し

となっている。

リンク先では Haskell でやっているので、Scheme でやってみた。Haskell と違って無限リストは扱えないので、スクリプトの引数で生成する数列の数を指定するようにした。

(use srfi-1)
(use gauche.sequence)

(define main
  (lambda (args)
    (let ((count (string->number (cadr args))))
      (print (look-and-say count)))))

(define look-and-say
  (lambda (count)
    (unfold (lambda (seed) (zero? (car seed)))
            (lambda (seed) (cadr seed))
            (lambda (seed) (list (- (car seed) 1) (las (cadr seed))))
            (list count "1"))))

(define las
  (lambda (s)
    (let ((ls (group-sequence s)))
      (apply string-append
        (append-map (lambda (e)
          (list (write-to-string (length e)) (string (car e))))
            ls)))))

unfold のために srfi-1 を、group-sequence のために gauche.sequence を読み込んでいる。
group-sequence はリストや文字列といった sequence を、同じ値ごとにグループ化する手続き。こんな感じ：

gosh> (group-sequence "aabccdddee")
((#\a #\a) (#\b) (#\c #\c) (#\d #\d #\d) (#\e #\e))

さて、実行してみよう。

takatoh@apostrophe $ gosh look-and-say.scm 8
(1 11 21 1211 111221 312211 13112221 1113213211)

うまくいったようだ。

増減を繰り返す整数のリストを作る

ちょっと面白いことをやってるのを見つけた。

　cf. 往復運動(レシプロ運動)を表現する連番リストを作る(srfi-1 iota の変種) – 分室の分室

リストを作るんであれば unfold が使えると思ってやってみた。省略可能な引数 shift の処理には let-optionals* を使った。

(use srfi-1)

(define reciprocating-motion
  (lambda (count start step limit . restargs)
    (let-optionals* restargs ((shift 0))
      (unfold (lambda (seed) (zero? (car seed)))
              (lambda (seed) (+ (cadr seed) shift))
              (lambda (seed)
                (let* ((c (car seed))
                       (s (caddr seed))
                       (v (+ (cadr seed) s)))
                (cond
                  ((< v 0) (list (- c 1) (- 0 v) (* s -1)))
                  ((> v limit) (list (- c 1) (- limit (- v limit)) (* s -1)))
                  (else (list (- c 1) v s)))))
                    (list count start step)))))

(print (reciprocating-motion 20 5 3 30))
(print (reciprocating-motion 20 5 3 30 50))
(print (reciprocating-motion 20 5 -5 30))
takatoh@apostrophe $ gosh reciprocating-motion.scm
(5 8 11 14 17 20 23 26 29 28 25 22 19 16 13 10 7 4 1 2)
(55 58 61 64 67 70 73 76 79 78 75 72 69 66 63 60 57 54 51 52)
(5 0 5 10 15 20 25 30 25 20 15 10 5 0 5 10 15 20 25 30)

できてると思う。

九九表のすべてのマスの和

前回から時間が開いてしまった。本当は Text.Parsec の話題を書こうと思ってるんだけど、今日も時間がないので小ネタ、しかも他人のネタ。

　cf. 九九表のすべてのマスの和 – 無駄と文化

詳しくはリンク先を見て。いくつかの言語でやってるんだけど、Ruby と Scheme がなかったのでやってみた。

まずは Ruby。

# encoding: utf-8

def sum_of_kuku
  a = (1..9).to_a
  a.product(a).map{|x,y| x * y}.inject(:+)
end

puts sum_of_kuku
takatoh@apostrophe $ ruby sum_of_kuku.rb
2025

１〜９までの配列の直積をとって、それぞれを掛けあわせて、最後に全部足してるだけ。

Scheme でも同じ考え方。でもリストの直積を取る手続きが見当たらなかったので direct-product を自作した。

(use srfi-1)

(define direct-product
  (lambda (lis1 lis2)
    (append-map
      (lambda (x) (map (lambda (y) (list x y)) lis2))
      lis1)))

(define sum-of-kuku
  (lambda ()
    (let ((l1 '(1 2 3 4 5 6 7 8 9))
          (l2 '(1 2 3 4 5 6 7 8 9)))
      (apply + (map (lambda (x) (apply * x)) (direct-product l1 l2))))))

(print (sum-of-kuku))
takatoh@apostrophe $ gosh sum-of-kuku.scm
2025

riffle-shuffle

「リフル・シャッフルとは、カードの山札を半分ずつに分けて、パラパラと交互に重ねていくトランプ札の切り方を言う」んだそうで。

　cf. riffle-shuffle (2つのリスト(の要素)を交互に混ぜる) – 分室の分室

詳しくはリンク先を見てもらうとして、要は２つのリストの要素を交互に混ぜようってことだ（て、リンクのタイトルに書いてあるじゃん）。

まあ、ベタに書こうと思うとリンク先のようなコードになるんだろうけど、ここは用意されている便利な手続きを使って：

gosh> (use srfi-1)
#<undef>
gosh> (concatenate (zip '(0 2 4 6 8) '(1 3 5 7 9)))
(0 1 2 3 4 5 6 7 8 9)

てなかんじで、どうっスか。

string-join

intersperse があれば string-join は簡単だ。デリミタを差し込んだ文字列のリストに string-append を適用してやればいい。

gosh> (apply string-append (intersperse "-" '("foo" "bar" "baz")))
"foo-bar-baz"

と、思ったら string-join には省略可能な引数 delim と grammer があった。

　cf. 6.12 文字列 – Gauche ユーザリファレンス

delim はデリミタで、省略すると空白文字１文字が使われる。

(define my-string-join
  (case-lambda
    ((slist) (my-string-join slist " "))
    ((slist delim)
    (apply string-append (intersperse delim slist)))))

(print (my-string-join '("foo" "bar" "baz")))
(print (my-string-join '("foo" "bar" "baz") "-"))
takatoh@apostrophe $ gosh my-string-join.scm
foo bar baz
foo-bar-baz

grammer は手続きの挙動を決めるためのシンボルで、infix、strict-infix、prefix、suffix のいずれか。
今回、strict-infix は面倒そうだったのでそれ以外を実装してみた。

(define my-string-join
  (case-lambda
    ((slist) (my-string-join slist " " 'infix))
    ((slist delim) (my-string-join slist delim 'infix))
    ((slist delim grammer)
      (let ((l (intersperse delim slist)))
        (cond ((eq? grammer 'infix) (apply string-append l))
              ((eq? grammer 'prefix) (apply string-append (cons delim l)))
              ((eq? grammer 'suffix) (apply string-append (append l (list delim))))
              (else (error "Illegal grammer.")))))))

(print (my-string-join '("foo" "bar" "baz")))
(print (my-string-join '("foo" "bar" "baz") "-"))
(print (my-string-join '("foo" "bar" "baz") "/" 'prefix))
(print (my-string-join '("foo" "bar" "baz") ";" 'suffix))
(print (my-string-join '("foo" "bar" "baz") ";" 'surfix)) ;; misspell
takatoh@apostrophe $ gosh my-string-join3.scm
foo bar baz
foo-bar-baz
/foo/bar/baz
foo;bar;baz;
gosh: "error": Illegal grammer.

intersperse

Haskell の Data.List モジュールに intersperse という関数がある。リストの要素の間に値を挿入する関数だ。

Prelude> import Data.List
Prelude Data.List> intersperse 0 [1..3]
[1,0,2,0,3]

これを自前で実装するとこうなる。

module Main where

intersperse :: a -> [a] -> [a]
intersperse _ (x:[]) = x : []
intersperse y (x:xs) = x : y : intersperse y xs

main :: IO ()
main = print $ intersperse 0 [1..3]
takatoh@apostrophe $ runhaskell intersperse.hs
[1,0,2,0,3]

素直な再帰関数だ。

Scheme ではどうだろうか。実は Gauche には intersperse が用意されているんだけど、自前で実装してみたらこうなった。

(define my-intersperse
  (lambda (delim lis)
    (let loop ((l (cdr lis)) (r (list (car lis))))
      (if (null? l)
        (reverse r)
        (loop (cdr l) (cons (car l) (cons delim r)))))))

(print (my-intersperse 0 '(1 2 3)))
takatoh@apostrophe $ gosh my-intersperse.scm
(1 0 2 0 3)

Haskell のと違って末尾再帰になっているのは、まあ、それが身についていると言ってもいいのかな。

さて、ここまで書いてみて畳み込みが使えそうだと気がついた。

(define my-intersperse
  (lambda (delim lis)
    (reverse (fold (lambda (x acc) (cons x (cons delim acc)))
      (list (car lis))
        (cdr lis)))))

(print (my-intersperse 0 '(1 2 3)))
takatoh@apostrophe $ gosh my-intersperse2.scm
(1 0 2 0 3)

同様に Haskell で。

module Main where

intersperse :: a -> [a] -> [a]
intersperse y xs = reverse $ foldl f [head xs] (tail xs)
  where
    f acc a = a : y : acc

main :: IO ()
main = print $ intersperse 0 [1..3]
takatoh@apostrophe $ runhaskell intersperse2.hs
[1,0,2,0,3]

Haskell の場合は foldl を使うよりも、単純な再帰のほうが見やすい気がする。それに Haskell は非正格だから、リスト全体をたどる必要（それも２回も）のある前者よりも後者のほうが効率がいいのかも。

string-reverse

SRFI-13 に string-reverse という手続きがある。その名のとおり、文字列を逆順にする手続きだ。

gosh> (use srfi-13)
#<undef>
gosh> (string-reverse "abcdefg")
"gfedcba"

で、何故か省略可能な引数が２つあって、逆順にするときの始端と終端を指定できる（逆順になった部分文字列が返ってくる）。

gosh> (string-reverse "abcdefg" 3)
"gfed"
gosh> (string-reverse "abcdefg" 3 5)
"ed"

これを自分で作ってみた。こないだの case-lambda の練習。

(define string-reverse
  (case-lambda
    ((s) (string-reverse s 0 (string-length s)))
    ((s start) (string-reverse s start (string-length s)))
    ((s start end)
      (let loop ((c 0) (l (string->list s)) (r '()))
        (cond ((= c end) (list->string r))
              ((< c start) (loop (+ c 1) (cdr l) r))
              (else (loop (+ c 1) (cdr l) (cons (car l) r))))))))

(print (string-reverse "abcdefg"))
(print (string-reverse "abcdefg" 3))
(print (string-reverse "abcdefg" 3 5))
takatoh@apostrophe $ gosh string-reverse.scm
gfedcba
gfed
ed

リストから要素を間引きする

真ん中優先。真ん中がないときは右側優先。

(define thin-out
  (lambda (lis n)
    (let* ((r (- (length lis) n))
      (a (if (= (mod r 2) 0) (/ r 2) (+ (div r 2) 1)))
      (b (+ a n)))
      (append (take lis a) (drop lis b)))))

(print (iota 10))
(print (thin-out (iota 10) 1))
(print (thin-out (iota 10) 2))
(print (thin-out (iota 10) 3))
^o^ > gosh thin-out.scm
(0 1 2 3 4 5 6 7 8 9)
(0 1 2 3 4 6 7 8 9)
(0 1 2 3 6 7 8 9)
(0 1 2 3 7 8 9)