Latest comments for language 'Clean' on doukaku.org

lethevert's comment on 必ず解ける迷路

「1024 x 1024」くらいならメモリ使用量が問題になることはないのかなと、あまり考えずに普通に書きました。

「1024 x 1024」で6秒くらい。CPUスペックは、AMD Athlon 64 X2の2GHzだったと思います。

アルゴリズムは、迷路の盤面を配列で用意して、１箇所から始めてランダムに少しずつ迷路を広げていく方法を取っています。

「10 x 10」のサンプル出力は次の通りです。

#####################
#     # #       #   #
# ### # # ####### ###
# #         #       #
# # # # # ### ### ###
# # # # #       # # #
# ### ##### # # ### #
# # #     # # #   # #
### # ### # ### ### #
#       # # #       #
# ### ######### ### #
# #           # # # #
### ### # ##### # ###
#     # #     #     #
# ##### # ####### ###
# #     #       # # #
####### # # # # ### #
#   #   # # # # # # #
# ##### ### # ### # #
#         # #       #
#####################

module Main

import Bool, Int, String, StringCast, Array
import System, Misc, StdIO, OptRandom, MersenneTwister, Trace

:: MazeCell = Cell !Bool !Bool //right, bottom

Start w
  # (t,w) = tickCount w
    (f,w) = stdio w
    (_,f) = writeLine 0 f
    (_,f) = writeMaze (maze n m (genRandInt t)) f
    (_,w) = close f w
  = w
  where
  cmd = getCommandLine
  n = toInt cmd.[1]
  m = toInt cmd.[2]
  get maze row col = maze.[row * n + col]

  writeMaze maze f = writeMaze maze 0 f
    where
    writeMaze maze row f
      | row == m = (PassV, f)
      = f |> write "#"
          $> printRoom 0
          $> write "\r\n#"
          $> printWall 0
          $> write "\r\n"
          $> writeMaze maze (row + 1)
      where
      m = size maze / n
      printWall col f
        | col == n = (PassV, f)
        = case get maze row col of
            Cell _ False = f |> write "##" $> printWall (col + 1)
            _            = f |> write " #" $> printWall (col + 1)

      printRoom col f
        | col == n = (PassV, f)
        = case get maze row col of
            Cell False _ = f |> write " #" $> printRoom (col + 1)
            _            = f |> write "  " $> printRoom (col + 1)

  writeLine col f
    | col == n = f |> write "#\r\n"
    = f |> write "##" $> writeLine (col + 1)

::*CellPool = CellPool !*{!(!Int,!Int)} !Int
isEmptyPool c=:(CellPool _ 0) = (True, c)
isEmptyPool c = (False, c)
getNextCell (CellPool ls sz) [r:rand]
    | sz == 1
      # (e1,ls) = ls![0]
      = (e1, CellPool ls 0, rand)
    # i = (abs r) rem sz
      (e1,ls) = ls![i]
      (e2,ls) = ls![sz-1]
      ls = {ls & [i] = e2}
    = (e1, CellPool ls (sz - 1), rand)
addCell x y (CellPool ls sz)
    # ls = {ls & [sz] = (x,y)}
    = CellPool ls (sz + 1)

maze n m rand =
    let
      sz = n * m
      marks = asUnboxedArray $ createArray sz False
      cells = asStrictArray $ createArray sz (Cell False False)
      pool = addCell 0 0 (CellPool (createArray sz (0,0)) 0)
    in
      expand marks cells pool rand
  where
    get x y arr = arr![x*n+y]
    put e x y arr = {arr & [x*n+y] = e}

    expand marks cells pool rand
      # (b,pool) = isEmptyPool pool
      | b = cells
      # ((x,y), pool, rand) = getNextCell pool rand
        (cand, marks) = filterCells marks [(x-1,y),(x,y-1),(x+1,y),(x,y+1)]
        (sel, rest, rand) = selectCells cand rand
      #! cells = updateCells x y sel cells
         marks = foldl (\marks (x,y) = put True x y marks) marks sel
         pool = foldl (\pool (x,y) = addCell x y pool) pool sel
      = case rest of
          [] = expand marks cells pool rand
          _  # pool = addCell x y pool
             = expand marks cells pool rand

    filterCells marks ls = f [] marks ls where
      f ls marks [] = (ls, marks)
      f ls marks [(x,y):ee]
        | x < 0 || y < 0 || x >= m || y >= n = f ls marks ee
        # (k,marks) = get x y marks
        | k = f ls marks ee
            = f [(x,y):ls] marks ee

    selectCells ls [r:rand] = let (e1,e2) = f ls 1 [] [] in (e1, e2, rand) where
      f [] _ e1 e2 = (e1, e2)
      f [e:ee] t e1 e2
        | r bitand t == 0 = f ee (t << 1) e1 [e:e2]
                          = f ee (t << 1) [e:e1] e2

    updateCells x y ls cells = f ls cells where
      f :: ![(Int,Int)] !*{!MazeCell} -> *{!MazeCell}
      f [] cells = cells
      f [(x1,y1):ls] cells
        # (c0, cells) = get x y cells
          (c1, cells) = get x1 y1 cells
        | x1 < x = let (Cell r b) = c1 in put (Cell r True) x1 y1 cells |> f ls
        | y1 < y = let (Cell r b) = c1 in put (Cell True b) x1 y1 cells |> f ls
        | x1 > x = let (Cell r b) = c0 in put (Cell r True) x y cells |> f ls
        | y1 > y = let (Cell r b) = c0 in put (Cell True b) x y cells |> f ls

[ Clean ] [ download code ] ]

lethevert's comment on 魔方分割数

魔方分割数 (Nested Flatten)

comb_sumで明らかに無駄な数え上げをしているところがあったので、それを削除しました

n=5で18秒まで減少しました

module Main

import Bool, Int, List, Array, ValueCast, StringCast, System, Misc, Trace

Start = length $
        divide n s ls
  where
  n = toInt getCommandLine.[1]
  ls = [1..n*n]
  s = sum ls / n

divide n s ls = search ls
  where
  search [] = [[]]
  search ls
    =  comb_sum s n ls
    |> map (\f = let
                   (f0,fr) = (head f, tail f)
                   rr = filter (\e = not (e <= f0 || fr contains e)) ls
                 in [[f:t] \\ t <- search rr])
    |> foldr (++) []

comb_sum :: Int Int [Int] -> [[Int]]
comb_sum s n [e:ee]
  | e > s = []
  = map ((:>) e) (comb_sum (s - e) ck ee) // <- この部分を修正
  where
  ck = reverse $ take (n-1) $ scan (+) 0 $ reverse $ ee
  comb_sum 0 [] _ = [[]]
  comb_sum _ [] _ = []
  comb_sum _ _ [] = []
  comb_sum s ck=:[c:cc] [e:ee]
    | e > s     = []
    | e < s - c = comb_sum s ck ee
                = map ((:>) e) (comb_sum (s-e) cc ee) ++ comb_sum s ck ee

[ Clean ] [ download code ] ]

lethevert's comment on 魔方分割数

魔方分割数 (Nested Flatten)

いくつか高速化を試して、一番効果の高かったcomb_sumでの置き換えだけを適用したもの。

n=5で、2分20秒

効果があまりなかったものは、コメントに記述してあります。

module Main

import Bool, Int, List, Array, ValueCast, StringCast, System, Misc

Start = length $
        divide n s ls
  where
  n = toInt getCommandLine.[1]
  ls = [1..n*n]
  s = sum ls / n

divide n s ls = search ls
  where
  search [] = [[]]
  search ls
    =  comb_sum s n ls
    |> map (\f = let
                   (f0,fr) = (head f, tail f)
                   rr = filter (\e = not (e <= f0 || fr contains e)) ls
                 in [[f:t] \\ t <- search rr])
    |> foldr (++) []

comb_sum :: Int Int [Int] -> [[Int]]
comb_sum 0 0 _ = [[]]
comb_sum _ 0 _ = []
comb_sum s _ [] = []
comb_sum s n [e:rr]
  | e > s
    = comb_sum s n rr
    = map ((:>) e) (comb_sum (s-e) (n-1) rr) ++ comb_sum s n rr

/*
  //1. filterの部分をrest_of関数で置き換え
  search [] = [[]]
  search ls
    =  comb_sum s n ls
    |> map (\f = let rr = rest_of f ls
                 in [[f:t] \\ t <- search rr])
    |> foldr (++) []

  rest_of _ [] = []
  rest_of es=:[e:ee] ls=:[l:ll]
    | l <= e = rest_of es ll
    = rm ee ls
    where
    rm _ [] = []
    rm [] ls = ls
    rm es=:[e:ee] ls=:[l:ll]
      | l < e  = [l: rm es ll]
      | e == l = rm es ll
               = rm ee ls

  //2. searchで直接グループわけの個数を計算
  search [] = 1
  search ls
    =  comb_sum s n ls
    |> map (\f = let rr = rest_of f ls
                 in search rr)
    |> sum
*/

[ Clean ] [ download code ] ]

lethevert's comment on 魔方分割数

魔方分割数 (Nested Flatten)

とりあえずナイーブに実装。

n=4の場合、0.04秒ですが、n=5の場合、5分経っても終わらないです。

module Main

import Bool, Int, List, Array, ValueCast, StringCast, System, Misc

Start = length $ divide n s ls
  where
  n = toInt getCommandLine.[1]
  ls = [1..n*n]
  s = sum ls / n

divide n s ls = search ls
  where
  search [] = [[]]
  search ls
    =  comb n ls
    |> filter (\f = sum f == s)
    |> map (\f = let
                   (f0,fr) = (head f, tail f)
                   rr = filter (\e = not (e <= f0 || fr contains e)) ls
                 in [[f:t] \\ t <- search rr])
    |> foldr (++) []

comb :: Int [a] -> [[a]]
comb 0 _ = [[]]
comb _ [] = []
comb n [e:rr]
  =  map ((:>) e) (comb (n-1) rr)
  ++ comb n rr

[ Clean ] [ download code ] ]

lethevert's comment on ポーカーの役判定

ポーカーの役判定 (Nested Flatten)

初投稿です。Cleanです。この辺のライブラリを使ってます。

http://sourceforge.net/projects/cleanoptenv

module Main

import System, Int, Char, String, List, Misc, MergeSort, ValueCast

Start
  | flush cards
    | straight cards
      | 14 == num (head cards)
        = "Royal flush"
      = "Straight flush"
    = "Flush"
  | straight cards
    = "Straight"
  | 4 == head groups
    = "Four of a kind"
  | 3 == head groups
    | 2 == groups !! 1
      = "Full house"
    = "Three of a kind"
  | 2 == head groups
    | 2 == groups !! 1
      = "Two pair"
    = "One pair"
  = "No pair"
  where
  cards = sortBy (>) $ parseCards getCommandLine.[1]
  groups = sortBy (>) $ map length $ groupCards [[]] 0 cards

:: Card = Card !Char !Int //suit num(2..14)
instance < Card where
  (<) (Card s0 n0) (Card s1 n1) = n0 < n1

suit (Card s n) = s
num (Card s n) = n

parseCards t = p 0
  where
  l = size t
  p i | i >= l = []
      = [Card s n: p (i+2)]
    where
    s = t.[i]
    n = case t.[i+1] of
          'A' = 14
          'K' = 13
          'Q' = 12
          'J' = 11
          'T' = 10
          c   = toInt (c - '0')

groupCards ls _ [] = ls
groupCards [l:ll] m [c=:Card s n: rest]
  | m == n = groupCards [[c:l]:ll] n rest
           = groupCards [[c],l:ll] n rest

flush cards = and $ zipWith (==) suits (tail suits)
  where
  suits = map suit cards

straight cards = (and $ zipWith (\a b = a == b + 1) nums (tail nums))
              || caseAce nums
  where
  nums = map num cards
  caseAce [14,5,4,3,2] = True
  caseAce _ = False

[ Clean ] [ download code ] ]

mz's comment on 与えた条件を満たす候補

与えた条件を満たす候補 (Nested Flatten)

module xop
import StdEnv;($) infixr 1;($) a b :== a b;(>>.) infixl 0;(>>.) a b = \ w -> (\ (_, w) -> b w) (a w);(>>=) infixl 0;(>>=) a b = \ w -> (\ (x, w) -> b x w ) (a w);liftM m :== \ lst -> \ w ->  (m lst, w);join del [x:xs]= (toString x) +++ del +++ (join del xs);join _ [] = "";putStr str = \w -> (stdio >>= liftM ( fwrites str) >>= fclose) w;Start w =snd $ main w;
main = putStr $ join "\n" $ map (join ",") $ xop [And, Or, Not, And]
tf = [True, False]
:: XopOp = And |Or |Not
xopisNot Not = True
xopisNot _ = False
xop :: [XopOp] -> [[Bool]]
xop oplis = foldl (\ knil x  -> if (xopSatisfaction oplis x ) [x:knil] knil) [] $ crossProduct $ take n $ repeat tf  where
    n = length oplis  +  1  -  length (filter xopisNot oplis)
xopSatisfaction x org= lp x org where
    lp [And:Not:xs] [y:y2:ys] = lp xs [y && (not y2):ys]
    lp [And:xs] [y:y2:ys] = lp xs [y && y2:ys]
    lp [Or:Not:xs]  [y:y2:ys] = lp xs [y || (not y2):ys]
    lp [Or:xs]  [y:y2:ys] = lp xs [y || y2:ys]
    lp []  [y:ys]         = y
    lp _  [] = abort "test"
crossProduct x :== cp [] x where
    cp knil [[x:xs]:ys] = (cp knil [xs:ys]) ++ cp [x:knil] ys
    cp knil [[]:ys] =  []
    cp knil [] =  [knil]

[ Clean ] [ download code ] ]

mz's comment on Hello, world!

Hello, world! (Nested Flatten)

よりhaskell風に

1
2
3

module hello
import StdEnv;($) infixr 1;($) a b :== a b;(>>.) infixl 0;(>>.) a b = \ w -> (\ (_, w) -> b w) (a w);(>>=) infixl 0;(>>=) a b = \ w -> (\ (x, w) -> b x w ) (a w);liftM m :== \ lst -> \ w ->  (m lst, w);join del [x:xs]= (toString x) +++ del +++ (join del xs);join _ [] = "";putStr str = \w -> (stdio >>= liftM ( fwrites str) >>= fclose) w;Start w =snd $ main w;
main = putStr "Hello," >>. putStr " World!\n"

[ Clean ] [ download code ] ]

mz's comment on 全ての組み合わせ

全ての組み合わせ (Nested Flatten)

ブランクありで適当なのでコードがダサいかも。
簡単なので大丈夫なはずだが。

module crossproduct
import StdEnv
($) infixr 1;($) a b :== a b;(>>=) infixl 0;(>>=) a b = \ w -> (\ (x, w) -> b x w ) (a w);liftM m :== \ lst -> \ w ->  (m lst, w);
join del [x:xs]= (toString x) +++ del +++ (join del xs);
join _ [] = "";
:: Elem= ElemChar Char | ElemStr String | ElemInt Int
class toElem a  where
    toElem :: a -> Elem
instance toElem Int where
    toElem a = ElemInt a
instance toElem Char where
    toElem a = ElemChar a
instance toElem String where
    toElem a = ElemStr a
instance toString Elem where
    toString (ElemInt a) = toString a
    toString (ElemStr a) = a
    toString (ElemChar a) = toString a
Start w =snd ((stdio >>= liftM ( fwrites str) >>= fclose) w)
    where str = join "\n" $ map (join ",") $ crossProduct [] elems2
          elems2 = [map toElem [0,1],map toElem ['ab'], map toElem ["Foo","Bar"]]
crossProduct :: [Elem] [[Elem]] -> [[Elem]]
crossProduct knil [[x:xs]:ys] = crossProduct [x:knil] ys ++ (crossProduct knil [xs:ys])
crossProduct knil [[]:ys] =  []
crossProduct knil [] =  [knil]

[ Clean ] [ download code ] ]

mz's comment on ダブル完全数

ダブル完全数 (Nested Flatten)

module doubleperfect
import StdEnv, StdStrictLists, StdOverloadedList
Start w =snd ((stdio >>= liftM ( fwrites str) >>= fclose) w)
    where str = join $ filter isDoublePerfect [1..10001]
isDoublePerfect i = (Foldl (\x y -> x + y) 0 $ divisors i) == (i + i - 1)
divisors i =  [! j + (i/j) \\ j <- [2..(toInt $ sqrt $toReal i)] | (i rem j) == 0 !]
join [x:xs]= toString x +++ "," +++ join xs
join [] = ""
($) infixr 1
($) a b :== a b
(>>=) infixl 0
(>>=) a b = \ w -> (\ (x, w) -> b x w ) $ a w
liftM m :== \ lst -> \ w ->  (m lst, w)

[ Clean ] [ download code ] ]

mz's comment on Hello, world!

Hello, world! (Nested Flatten)

// hello.icl
module hello
import StdEnv
($) infixr 1
($) a b :== a b
(>>=) infixl 0
(>>=) a b = \ w -> (\ (x, w) -> b x w ) $ a w
liftM m :== \ lst -> \ w ->  (m lst, w)
Start w = snd ((stdio >>= liftM (fwrites "Hello World!\n") >>= fclose) w)

[ Clean ] [ download code ] ]

oskimura's comment on 重複無し乱数

重複無し乱数 (Nested Flatten)

Cleanでやってみた。
擬似乱数を生成するライブラリをつかってます。
本当の乱数じゃないので、同じ数を与えると同じ乱数表になってしまう…

module RandList
import StdEnv, MersenneTwister

Start = bingo 10
bingo n  = map snd  (sort  (zip ((genRandInt n),[1..n])))

[ Clean ] [ download code ] ]