DouKaku?beta

Language detail: Clean

Coverage: 5.71%
number of '+' ratings
 contribution for coverage

Unsolved challenges

show all

codes

Feed

Used modules

必ず解ける迷路 (Nested Flatten)

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

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

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

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

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

see: AltEnvライブラリを使っています 

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
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
魔方分割数 (Nested Flatten)

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

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

see: AltEnvライブラリを使っています 

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
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

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

n=5で、2分20秒

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

see: AltEnvライブラリを使っています 

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
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
*/

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

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

see: AltEnvライブラリを使っています 

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
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
ポーカーの役判定 (Nested Flatten)

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

http://sourceforge.net/projects/cleanoptenv 

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
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
与えた条件を満たす候補 (Nested Flatten) 

	

	
	
	
    

      
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
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]




    

	

  
  





    
    


    

    
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"




    

	

  
  





    
    


    

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

    
    






  
  

	

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


	

	
	
	
    

      
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
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]




    

	

  
  





    
    


    

    
ダブル完全数
(Nested 
 Flatten)

    
    






  
  

	

	  

	

	
	
	
    

      
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
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)




    

	

  
  





    
    


    

    
Hello, world!
(Nested 
 Flatten)

    
    






  
  

	

	  

	

	
	
	
    

      
1
2
3
4
5
6
7
8
9
// 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)




    

	

  
  





    
    


    

    
重複無し乱数
(Nested 
 Flatten)

    
    






  
  

	

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

	

	
	

	  see: 
	
  
	
	
	
    

      
1
2
3
4
5
module RandList
import StdEnv, MersenneTwister

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




    

	

  
  





    
    



















Index





Feed










Other





Link




Pathtraq



loading...














Creative Commons License
このサイトの内容は、
クリエイティブ・コモンズ・ライセンスの下でライセンスされています。
[詳細]