HaHaHa!(old)

2006-10-27

覆面算汎用ソルバ

[1..100]>>=pen さんのコメントを受けての汎用の覆面算ソルバ?

% alphametic "SEND+MORE=MONEY"
SEND+MORE=MONEY
9567+1085=10652
% alphametic "KYOTO+OSAKA=TOKYO"
KYOTO+OSAKA=TOKYO
41373+32040=73413
% alphametic "APPLE+GRAPE=CHERRY"
APPLE+GRAPE=CHERRY
63374+90634=154008
% alphametic "SIX+SEVEN+SEVEN=TWENTY"
SIX+SEVEN+SEVEN=TWENTY
650+68782+68782=138214

などなど.効率は考えていない素朴な実装は以下のとおり.

module Main (main) where

import Data.Char (isSpace, isAlpha)
import Data.List (nub,findIndex)
import Data.Maybe (catMaybes)
import Debug.Trace (trace)
import System.Environment (getArgs)

import Combinatorics (perm)
import Text.SimpleParser (Parser, runParser, sat, tok, item, (<|>))

-- Simple Functions

addArrow :: Eq a => (a,b) -> (a -> b) -> (a -> b)
addArrow (k,v) f x | k == x    = v
                   | otherwise = f x

genFun :: Eq a => [(a,b)] -> (a -> b)
genFun = foldr addArrow (error "Out of range")

-- Candidates

envs :: String -> String -> [Char -> Int]
envs s h = map genFun $ filter foo $ map (zip s) $ perm [0..9] (length s)
  where foo xs = all ((0 /=) . snd) $ map (xs !!) ixs
        ixs    = catMaybes $ map (flip findIndex s) $ map (==) h

s2int :: (Char -> Int)  -> String -> Int
s2int f = foldl (\ s d -> s*10 + f d) 0 

-- Lexer

lexer :: String -> ([String],String)
lexer "" = ([],"")
lexer ccs@(c:cs) | isSpace c = case span isSpace ccs of
                                 (_,cs') -> lexer cs'
		 | isAlpha c = case span isAlpha ccs of
                                 (xs,ys) -> case lexer ys of
                                              (ws,zs) -> (xs:ws,zs)
		 | otherwise = case lexer cs of
                                 (ws,zs) -> ([c]:ws,zs)

-- Expressions

data Expr = V String
          | A String Expr Expr
          | P Expr

data Expr' = V' Int
           | A' (String,Int->Int->Int) Expr' Expr'
           | P' Expr'

trans :: (Char -> Int) -> Expr -> Expr'
trans t (V v)      = V' $ s2int t v
trans t (A o e e') = A' (bop o) (trans t e) (trans t e')
trans t (P e)      = P' (trans t e)

interp :: Expr' -> Int
interp (V' v)      = v
interp (A' o e e') = (snd o) (interp e) (interp e')
interp (P' e)      = interp e

bop :: String -> (String, (Int -> Int -> Int))
bop = genFun [("+",("+",(+))),("-",("-",(-))),("*",("*",(*))),("/",("/",div))]

-- Parser

parseAlphametic :: Parser String (Expr, Expr)
parseAlphametic = do { l <- pExpr
		     ; tok "="
		     ; r <- pExpr
		     ; return (l,r)
		     }

pV :: Parser String Expr
pV = sat (all isAlpha) >>= return . V

pExpr :: Parser String Expr
pExpr =  do { x <- pExpr'
            ; o <- sat (flip elem ["+","-"])
            ; y <- pExpr
            ; return (A o x y)
            }
     <|> pExpr'

pExpr' =  do { x <- pAExpr
             ; o <- sat (flip elem ["*","/"])
	     ; y <- pExpr'
             ; return (A o x y)
             }
      <|> pAExpr

pAExpr =  do { tok "("
             ; e <- pExpr
             ; tok ")"
             ; return (P e)
	     }
      <|> pV

--
pprExpr :: Expr -> ShowS
pprExpr (V x)     = (x++)
pprExpr (A o l r) = pprExpr l . (o++) . pprExpr r
pprExpr (P e)     = ("("++) . pprExpr e . (")"++)

ppr :: (Expr,Expr) -> ShowS
ppr (e,e') = pprExpr e . ("="++) . pprExpr e'

pprExpr' :: Expr' -> ShowS
pprExpr' (V' x)     = (show x++)
pprExpr' (A' o l r) = pprExpr' l . (fst o++) . pprExpr' r
pprExpr' (P' e)     = ("("++) . pprExpr' e . (")"++)

ppr' :: (Expr',Expr') -> ShowS
ppr' (e,e') = pprExpr' e . ("="++) . pprExpr' e'

-- Alphametic

uniqStr :: [String] -> (String, String)
uniqStr s = (us,ts)
 where
  ss = filter (all isAlpha) s
  ts = map head ss
  us' = nub $ concat ss
  us  = if length us' > 10 then error "too many kinds of alphabets" else us'

alphametic :: String -> String
alphametic input 
  = unlines $ map (showSol (l,r)) sols
  where
    sols    = filter (flip okp (l,r)) binds
    (l,r)   = fst $ head $ runParser parseAlphametic lexemes
    binds   = uncurry envs $ uniqStr lexemes
    lexemes = fst $ lexer input
    
okp :: (Char -> Int) -> (Expr, Expr) -> Bool
okp b (e,e') = interp (trans b e) == interp (trans b e')

showSol :: (Expr, Expr) -> (Char -> Int) -> String
showSol (e,e') s = ppr' (trans s e, trans s e') ""

-- Main 

main :: IO ()
main = do { args <- getArgs
          ; case args of
              (a:_) -> putStrLn a >> putStr (alphametic a)
              _     -> putStrLn "no input"
	  }

module Combinatorics と module Text.SimpleParser はオレ様モジュール

Text.SimpleParser の中身は おてがるパーザコンビネータ - HaHaHa!(old) - haskell と同じ.perm の定義は以下のとおり

perm :: [a] -> Int -> [[a]]
perm [] _ = []
perm xs 0 = [[]]
perm xs 1 = map (:[]) xs
perm xs n = concat $ map (pm n) $ divid xs
 where pm _ (_,[])      = []
       pm n (hs,(t:ts)) = map (t:) $ perm (hs ++ ts) (n-1)

divid :: [a] -> [([a],[a])]
divid xxs@(x:xs) = ([],xxs) : [(x:ys,zs) | (ys,zs) <- divid xs]
divid []         = [([],[])]

[1..100]>>=pen [1..100]>>=pen 2006/11/01 19:21足し算専用ですが前に書いたやつを汎用化しました。
http://hpcgi2.nifty.com/1to100pen/wiki/wiki.cgi?p=%CB%E8%C6%FCHaskell の2006-11-01

ee3Nuchee3Nuch2017/01/22 10:09I would do anything for a girl who looks like this

<a href=http://mt.livecamfun.com/xtarc/609039/408/0/arg_tour=rex1/?mta=344021/><img>www.camsexcity.site/banner2.jpg</img></a>

WaynelumWaynelum2017/02/26 22:37MAVRO
Новый проект
Новая криптовалюта
Рост от 20 до 50 процентов в месяц!
Реферальная программа 14 уровней
mavro.ga


mavro.ga, mavro, mavro отзывы, mavro криптовалюта, mavro mmgp, mavro coin, mavro курс, мавроди mavro, mavro кран, mavro майнинг, новая криптовалюта mavro, mavro mining, mavro криптовалюта отзывы, валюта mavro, mavro coin курс, сколько монет в найденном блоке mavro

MichaelHopMichaelHop2017/06/27 09:16檢查最可靠和最好的外匯經紀人 fx-brokers-review.com/index_tw.html