11月13日のネタ。とりあえず9x9限定です。 とりあえずソースはこんな感じでした。みなさんにいろいろとつっこまれましたが、とりあえず修正はしてません。それにしてもgoはいただけないね、我ながら。
-- 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 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"
まずは解ける入力パターン。
536827941 172964358 894153207 710349826 643782195 928516734 481295673 369471582 257638419
で、無限ループに陥ってるっぽいパターン。
030820901 172904358 890153207 000349826 643702195 928516734 481295673 369471582 057638419
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 かなりハイレベルにバカやってる感じ