http://factorcode.org/ 逆ポーランド記法な言語。"1 2 +"など、日本語だと思えばスラスラ読めます。
2次元配列仕様、16x16に対応。solve は複数解をリストで返します。ここではそのheadをとっているので、解がひとつ見つかりしだい終了します。 - げんま 06/11/25
import System import List import Array import Char import Monad dim = 16 sqrtdim = 4 isSingle [x] = True isSingle _ = False slice n [] = [] slice n l = a:(slice n b) where (a,b) = splitAt n l allCells = range ((0,0),(dim-1,dim-1)) rowCells idx = let (row,col) = idx in range ((row,0),(row,dim-1)) colCells idx = let (row,col) = idx in range ((0,col),(dim-1,col)) boxCells idx = let (row,col) = idx a = (row `div` sqrtdim) * sqrtdim b = (col `div` sqrtdim) * sqrtdim in range ((a,b),(a+(sqrtdim-1),b+(sqrtdim-1))) unfixedCells ar = filter (\idx -> not (isSingle (ar!idx))) allCells arrayList ar = [ar!idx | idx <- allCells] logicalSolve ar = let ar' = foldl f ar $ unfixedCells ar where f ar idx = ar//[(idx, getCandidate ar idx)] ar'' = foldl f ar' $ unfixedCells ar' where f ar idx = case find isSingle $ map (\func -> ar!idx \\ concat [ar!n | n <- func idx, n /= idx]) [rowCells, colCells, boxCells] of Nothing -> ar Just x -> ar//[(idx, x)] in if any (\idx -> ar!idx /= ar''!idx) $ allCells then logicalSolve ar'' else ar'' candarList ar = [ar//[(idx,[x])] | x <- ar!idx] where idx = head $ unfixedCells ar solve ar | all (\idx -> isSingle (ar!idx)) $ allCells = return ar | any (\idx -> (ar!idx) == []) $ allCells = fail "fail" | otherwise = do candar <- candarList ar solve (logicalSolve candar) getCandidate ar idx = let used = concat [ar!x | x <- rowCells idx ++ colCells idx ++ boxCells idx, isSingle (ar!x)] in [1..dim] \\ used main :: IO () main = do [file] <- getArgs contents <- readFile file let start = listArray ((0,0),(dim-1,dim-1)) $ map (\x -> if x == [0] then [1..dim] else x) $ map (\x -> [(mdigitToInt x)]) (concat (lines contents)) printArray (head (solve (logicalSolve start))) where printArray ar = mapM_ putStrLn $ (slice dim l) ++ ["\n"] where l = map mintToDigit (concat (arrayList ar)) mdigitToInt x | isDigit x = digitToInt x | x == 'a' = 10 | x == 'b' = 11 | x == 'c' = 12 | x == 'd' = 13 | x == 'e' = 14 | x == 'f' = 15 | x == 'g' = 16 | otherwise = -1 mintToDigit x | x < 10 = intToDigit x | x == 10 = 'a' | x == 11 = 'b' | x == 12 = 'c' | x == 13 = 'd' | x == 14 = 'e' | x == 15 = 'f' | x == 16 = 'g' | otherwise = '0'
入力 050g02c00f70b080 0008500f300dc000 c0e0100b80090d03 0f00030000e00010 3000006974000001 00b5380000fc6700 208700500a00df04 0c0e00400d009030 006080f00c030b00 490fcab005g83027 00c0000340000500 80030007b000a00c 0e006f3008c100b0 03d0000cf0000g60 004b00000000fc00 f0004b0e50670008 出力 d53ge2c61f74b98a b128549f3gadce76 c7e41gab86592df3 af96d378cbe2541g 3afd2c6974beg851 94b538dg21fc67ae 2687be519a3gdfc4 1cgef74a6d85923b 7g6285f4ac13eb9d 491fcabde5g83627 ebca912347d685gf 8d53g6e7b29fa14c ge796f32d8c14ab5 53d1a98cfe4b7g62 684b7d15g32afce9 f2ac4bge596713d8
timeは、0m2.065s @ Pen4 2.6GHz
11月13日のネタ。とりあえず9x9限定です。 とりあえずソースはこんな感じでした。みなさんにいろいろとつっこまれましたが、とりあえず修正はしてません。それにしてもgoはいただけないね、我ながら。
(追記)Haskell Hackerにデバッグしていただきました!
-- Leftが不確定要素(リスト)でRightが確定要素 import System import Array -- 最初のLeftを見つけて候補のリストを作る。 go ar = case first 0 of Nothing -> [Right ar] Just n -> map (?c -> Left $ ar//[(n,Right c)]) (getCandidate n) where first n = if n>80 then Nothing else case ar!n of Right _ -> first (n+1) Left _ -> Just n -- 候補のリストを作る関数 getCandidate n = let used = getRow n ar ++ getCol n ar ++ getBox n ar in [x|x<-"123456789", notElem x used] -- 9x9 の数独を想定。使われている関数を見つけ出す関数 getRow n ar = let row = n `div` 9 in concatMap (?n -> case ar!(row*9+n) of Right x -> [x] Left _ -> []) [0..8] getCol n ar = let col = n - (n `div` 9 * 9) in concatMap (?n -> case ar!n of Right x -> [x] Left _ -> []) [col,col+9..col+72] getBox n ar = let line = n `div` 9 -- 行 col = n - (n `div` 9 * 9) -- 列 -- i = line `div` 3 -- 左上のy i = line `div` 3 * 3 -- 左上のy <- ここを修正! j = col `div` 3 * 3 -- 左上のx in concatMap (?n -> case ar!n of Right x -> [x] Left _ -> []) [x*9+y|x<-[i..i+2], y<-[j..j+2]] -- ファイルからデータを読み込んで最初の配列を作る main :: IO () main = do args <- getArgs case args of [] -> return () _ -> do contents <- readFile (args!!0) let start = array (0,80) $ zip [0..] [if cs=='0' then Left "0" else Right cs|cs<-contents, cs/='?n'] answer = next [Left start] putStr9 $ map (?n -> fromRight $ answer!n) [0..80] where next ars = case get ars of -- ここを回る [a] -> a -- found! [] -> next (next' ars >>= go) -- not yet found next' [] = [] -- Leftをはがす関数 next' (x:xs) = case x of Left ars -> ars : next' xs Right _ -> error "you never see this message." get [] = [] -- 終了したもの(Right)があるかどうか get (x:xs) = case x of Right a -> [a] Left _ -> get xs putStr9 [] = return () putStr9 str = do let (a,b) = splitAt 9 str putStrLn a putStr9 b fromRight x = case x of Right y -> y _ -> error "This is left"
入力例。
006000001 070060050 800103200 005040800 040702090 008010700 001205003 060070080 200000400
出力。
536827941 172964358 894153267 715349826 643782195 928516734 481295673 369471582 257638419
ちなみに、PowerPC 1GHzのiBookで
0.16s user 0.02s system 76% cpu 0.236 total
でした。
S E N D + M O R E ---------- M O N E Y (S,M != 0)
let toint (li : int list) = List.fold_left (fun a b -> (a * 10 + b)) 0 li;; let check (d : (char * int) list) = let f l = (toint (List.map (fun a -> List.assoc a d) l)) in ((List.assoc 'S' d != 0) && (List.assoc 'M' d != 0) && ((f ['S'; 'E'; 'N'; 'D']) + (f ['M'; 'O'; 'R'; 'E']) = (f ['M'; 'O'; 'N'; 'E'; 'Y'])));; let rec search dict letters numbers = match letters with [] -> if check dict then [dict] else [] | a :: letters -> let rec choose tried numbers = match numbers with [] -> [] | n :: numbers -> let sols = search ((a, n) :: dict) letters (tried @ numbers) in sols @ choose (n::tried) numbers in choose [] numbers ;; let rec interval m n = if m > n then [] else m :: interval (m+1) n;; let solve () = search [] ['S';'E';'N';'D';'M';'O';'R';'Y'] (interval 0 9);; solve();;
ライブラリに、順列組み合わせのpermutationなどがあったので、かなり楽ができました。見つかったらreturnラベルで大域脱出。2.6Ghzで13秒。 - げんま
(use srfi-1) (use util.combinations) (use util.match) (define return #f) (define (eval-poly li x) (fold (lambda (a b) (+ a (* b x))) 0 li)) (define (check li) (match li ((S E N D M O R Y) (if (and (not (= S 0)) (not (= M 0)) (= (+ (eval-poly (list S E N D) 10) (eval-poly (list M O R E) 10)) (eval-poly (list M O N E Y) 10))) (return (list S E N D '+ M O R E '= M O N E Y)))))) (define (solve) (combinations-for-each (lambda (a) (permutations-for-each check a)) (iota 10) 8)) (print (call/cc (lambda (cc) (set! return cc) (solve))))
(追記:nobsunさんのコードのほうがスマート。) (らくがきえんじんにも書いた。)
何も考えてない。15分くらいででけた。こういう問題にはリストモナドがめっぽう強い。(けいご) Showのインスタンスが必要なのはご愛嬌。
import Control.Monad.State ten = [0..9] -- StateT [Int] [] Intが何であるかを考えるより、単に [Int]->[(Int,[Int])] だと思えばよい -- (「リストlを貰って、その中のどれかの要素eと、lからeを取った残りl'の対(e,l')を返す」という非決定的な関数) getNum :: StateT [Int] [] Int getNum = StateT $ ?ns -> do{n <- ns; return (n, filter (n/=) ns)} sendmory = do s <- getNum if s==0 then lift [] else return () m <- getNum if m==0 then lift [] else return () e <- getNum n <- getNum d <- getNum o <- getNum r <- getNum y <- getNum if s*1000+e*100+n*10+d+m*1000+o*100+r*10+e==m*10000+o*1000+n*100+e*10+y then return (s,e,n,d,m,o,r,y) else lift [] instance (Show s, Show e, Show n, Show d, Show m, Show o, Show r, Show y)=> Show (s,e,n,d,m,o,r,y) where show (s,e,n,d,m,o,r,y) = "("++show s++","++show e++","++show n++","++show d++","++show m++","++show o++","++show r++","++show y++")" main = print (evalStateT sendmory ten)
sydney$ ghc -package mtl Desktop/hoge.hs -o a.out sydney$ time ./a.out [(?,?,?,?,?,?,?,?)] real 0m4.544s user 0m4.341s sys 0m0.076s
体感5秒位 (PPC, 2.3GHz dual) ただし今インタプリタ(ghci)で試したら25秒くらいかかった。
(use srfi-1) ;; stack of cc. (define fail '()) ;; nondeterminsm operator (define (amb li) (if (null? li) ((pop! fail)) (call/cc (lambda (cc) (push! fail (lambda () (cc (amb (cdr li))))) (car li))))) (define (toint li) (fold (lambda (a b) (+ a (* b 10))) 0 li)) (define (solve) (let ((digs (iota 10 0)) (digs1 (iota 9 1))) (let* ((S (amb digs1)) (E (amb (lset-difference = digs (list S)))) (N (amb (lset-difference = digs (list S E)))) (D (amb (lset-difference = digs (list S E N)))) (M (amb (lset-difference = digs1 (list S E N D)))) (O (amb (lset-difference = digs (list S E N D M)))) (R (amb (lset-difference = digs (list S E N D M O)))) (Y (amb (lset-difference = digs (list S E N D M O R))))) (if (= (+ (toint (list S E N D)) (toint (list M O R E))) (toint (list M O N E Y))) (list S E N D '+ M O R E '= M O N E Y) (amb '()))))) (print (call/cc (lambda (cc) ;; initial value for fail (push! fail (lambda () (cc 'no-choise))) (solve))))
例えば、 (let ((i (amb 4 6 7)) (j (amb 5 8 11))) (if (prime? (+ i j)) (list i j) (amb))) ;Value 23: (6 5) のようにすると '(4 6 7) と '(5 8 11) のうちから二つの数の和が素数になる組の1つを返します。
これを理解するのに、自分は3ヶ月かかりました。 ambは、バックトラック演算子です。動きを大雑把に言うと、
(let (i (amb 4 6 7))で、 i に 4 が入ると同時に、 この時点のツヅキ、
"6 7)) (j (amb 5 8 11))) (if (prime? (+ i j)) (list i j) (amb)))"
を取り出して、スタックにpush。
次の行、 (j (amb 5 8 11))で、 j に 5が入ると同時に、 この時点のツヅキ、
"8 11))) (if (prime? (+ i j)) (list i j) (amb)))"
を取り出して、スタックにpush。
(prime? (+ 4 5))は偽。(amb)が動く。amb関数は、引数なしで呼ばれると、スタックをpopして、中身の、ツヅキを実行。
"8 11))) (if (prime? (+ i j)) (list i j) (amb)))"
が実行されて、jに8が入ると同時に、 この時点のツヅキ、
"11))) (if (prime? (+ i j)) (list i j) (amb)))"
を取り出して、スタックにpush...という感じです。
Jekyll is a high-level language that can be losslessly translated to and from readable editable C. This allows it to be used in C projects, with C programmers, C libraries, and C tools.
(今井) http://cristal.inria.fr/%7Eddr/mlrogue/
AAで折れ線グラフを書くというお題.
入力は'R','F','C'の3種類も文字からなる長さ1以上の文字列
'R'は上昇を表し,折れ線グラフの要素としては '/' (スラッシュ)1文字に対応
'F'は下降を表し,折れ線グラフの要素としては '?' (バックスラッシュ)1文字に対応
'C'は変化なしを表し,折れ線グラフの要素としては'_'(アンダスコア)1文字に対応
たとえば,
$ ./plot RCRFCRFFCCRFFRRCRRCCFRFRFF
とすると
__ / ?/?/? _/?_/? _/ ? / ?__/? / ?/
が出力されるようなスクリプトを書け.
--nobsun
源馬のSchemeでの回答はこちら。
http://www.shiro.dreamhost.com/scheme/wiliki/wiliki.cgi?gemma -- 源馬? 2006-07-01 (土) 12:00:06
下村です。 無駄に長い上に汚いですけど…。
output str = let result = graph str output' :: [String] -> IO () output' mat = if any null mat then return () else do if any (' '/=) h then putStrLn h else return () output' t where h = map head mat t = map tail mat in output' result graph :: String -> [String] graph str = let height = (length str) * 2 graph' [] _ = [] graph' (x:xs) pos = case x of 'R' -> oneline (pos) '/' height : graph' xs (pos-1) 'F' -> oneline (pos+1) '??' height : graph' xs (pos+1) 'C' -> oneline pos '_' height : graph' xs pos in graph' str (length str) -- n番目の文字がcであるような、長さlの文字列を生成する oneline :: Int -> Char -> Int -> String oneline _ _ 0 = "" oneline n c l = (if n==0 then c else ' ') : oneline (n-1) c (l-1)
で、結果は…
Main> output "RCRFCRFFCCRFFRRCRRCCFRFRFF" __ / ?/?/? _/?_/? _/ ? / ?__/? / ?/ Main>
また下村です。OCamlで書き換えたので書いときます。Haskell版より関数とかをちょっと整理しました。あと、文字列はコマンドライン引数で指定するようにしてあります。explodeとimplodeは拡張ライブラリ関数なので、コンパイルするためにはExtLib?をインストールする必要があります。
(* <<COMPILE>> "ocamlopt -I +extlib extlib.cmxa lineGraph.ml" *) open ExtString.String;; open List;; exception NotRFC;; let any = List.fold_left (or) false;; let graph charlist = let height = (length charlist) * 2 in let rec transpose mat = if any (map (fun x -> x=[]) mat) then [] else map hd mat :: transpose (map tl mat) in let rec oneline n c l = if l=0 then [] else (if n=0 then c else ' ') :: oneline (n-1) c (l-1) in let rec graph' charlist pos = match charlist with [] -> [] | c::cs -> match c with 'R' -> oneline (pos) '/' height :: graph' cs (pos-1) | 'F' -> oneline (pos+1) '??' height :: graph' cs (pos+1) | 'C' -> oneline pos '_' height :: graph' cs pos | otherwise -> raise NotRFC in transpose (graph' charlist (length charlist));; let output = try let result = map (fun l -> if any (map (fun x -> x<>' ') l) then implode l ^ "?n" else "") (graph (explode Sys.argv.(1))) in let rec output' list = match list with [] -> () | (""::ls) -> output' ls | (l::ls) -> print_string l; output' ls in output' result with NotRFC -> print_string ("Usage : " ^ Sys.argv.(0) ^ " [RFC]*?n") | Invalid_argument _ -> print_string ("Usage : " ^ Sys.argv.(0) ^ " [RFC]*?n");;
実行結果は…
mac{sho}% ./a.out RCRFCRFFCCRFFRRCRRCCFRFRFF [~/src/ocaml] __ / ?/?/? _/?_/? _/ ? / ?__/? / ?/ mac{sho}% [~/src/ocaml]
http://www.cse.ogi.edu/~hallgren/House/ -- 源馬? 2006-07-04 (火) 16:16:05
The Evolution of a Haskell Programmer かなりハイレベルにバカやってる感じ