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

ScottJexScottJex2017/10/11 22:16Hi

DannyfesDannyfes2017/11/04 16:11advance cash <a href=http://installmentloansonlinei.org>online installment loans</a> low interest personal loans <a href=http://fastcashloansionline.org>need cash fast</a>

DannyfesDannyfes2017/11/04 17:11cash payday loans <a href=http://cashadvanceloansionline.org>cash advance</a> need money today <a href=http://paydayloansonlinei.org>online payday loan</a>

DannyfesDannyfes2017/11/25 02:06make fast cash <a href=http://cashloansonlinepro.org>cash loans with monthly payments</a> approved cash advance <a href=http://paydayloandirectilender.org>direct payday loan lenders</a>

DannyfesDannyfes2017/11/27 12:44installment loans direct lenders <a href=http://onlineloansnocreditcheckinstantapproval.org>online loans for bad credit direct lender</a> secured personal loan <a href=http://installmentloanspro.org>bad credit installment loan direct lender</a>

DannyfesDannyfes2017/11/30 15:46installment loans direct lenders <a href=http://onlineloansbadcredit.org>online loans bad credit</a> cash fast <a href=http://personalinstallmentloans.org>apply for installment loan</a>

KevinrupKevinrup2017/12/03 11:39Праздники и дни рождения, которые мы отмечаем, обычно не обходятся без цветов. Цветы оставляют впечатляющие воспоминания о любой дате. У каждого человека есть цветок, которому он отдаёт предпочтение из громадного разнообразия. У нас в широком цветочном ассортименте вы найдете цветы на любой вкус.
Если вы не уверены в точных предпочтениях того, кому хотите купить цветы, можете остановиться на красивых букетах. Наши букеты собраны профессиональными флористами. Букет из ярких роз, красивых орхидей, прекрасных хризантем и других, поражающих особой красотой цветов, будет отличным подарком, как даме, так и джентльмену. Если вы хотите доставить радость девушке, то купите к букетук примеру мягкую игрушку. Данный сюрприз будет по душе каждой представительнице слабого пола.
Розы считаются самыми популярными цветами. Даря розы, вы конечно же угодите любому человеку. Эти прекрасные цветы излучают уникальный аромат, который может радовать продолжительное время. У нас на складе имеется большой выбор сортов роз разнообразной высоты и цветовой гаммы.

<a href=http://sale-flowers.org/>цветы с доставкой</a>

На вопросы относительно подбора букета или создания его по своему заказу ответят наши флористы.
КУПОН СКИДКИ: FORUM

DannyfesDannyfes2017/12/05 05:31installment loans <a href=http://fastpaydayloanspros.org>payday loans</a> fast payday loans <a href=http://paydayadvanceloanspros.org>payday loans fast</a>

DannyfesDannyfes2017/12/08 17:26online loan companies <a href=http://paydayloansnearmepros.org>no credit check payday loans</a> personal loan interest rates <a href=http://paydayloansdirectlender.org>payday loans near me</a>