No Such Blog or Diary

«Prev || 1 | 2 | 3 |...| 866 | 867 | 868 |...| 925 | 926 | 927 || Next»

逆さにしても英単語になる英単語を

Aspell の英語辞書から単語を抜き出して全探索してみた.登録されている単語数は 141891 らしい.んで,1文字の単語を抜いてさかさまにしても単語があったのは 381 個.うち palindrome になっているものが 112 個.自身にもどらずほかの単語になるのが 269 個.さらに長さが4以上であるものは 137 個(これらの結果は複数形の s や動詞の変化をはじいていない)

よく知った単語の例:

emit ⇔ time

evil ⇔ live

flow ⇔ wolf

keep ⇔ peek

loop ⇔ pool

part ⇔ trap

プログラム結果

ICPC by Haskell

なぜか D を飛ばしてICPC2005 Regional, Tokyo の問題Eを Haskell で.全生成して条件で filter して max とるという非常に美しい形に...

 -- Problem E in ACM/ICPC 2005 ASIA Regional Tokyo
 -- 2005/11/04   Brute Force (42 * 2^5)
import Control.Monad
import Debug.Trace
import List
main = getProblems >>= mapM_ (putStrLn.(\r -> if r < 0 then "-1" else show r).solve)
 
getProblems = 
    do
    n <- liftM (head.map read.words) getLine
    replicateM n getProblem
 
getProblem =
    do
    r <- getNum
    s <- liftM (head.map read.words) getLine
    ws <- replicateM s getNum
    return (r, ws)
    where 
    getNum = liftM (head.map read.words) getLine :: IO(Double)
 
solve :: (Double, [Double])->Double
solve (r, ws) = foldl max (-1.0).filter (<r).map(\(lw, rw)->lw+rw).concat.map genWidth.concat.map genTree.perm $ ws
 
data BTree a = Node a (BTree a) (BTree a)
             | Leaf a
genTree ] = [Leaf
genTree xs = [ Node (weight t + weight u) t u | i <- [1..length xs-1], t<-genTree (take i xs), u<-genTree (drop i xs)]
weight (Leaf x) = x
weight (Node x _ _) = x
genWidth (Leaf x) = [(0.0,0.0)]
genWidth (Node _ l r) = let
                        ls = genWidth l
                        rs = genWidth r
                        lw = weight l
                        rw = weight r
                        la = lw/(lw + rw)
                        ra = 1-la
                        in [x | (ll,lr)<-ls, (rl,rr)<-rs, x<-gen ll lr rl rr la ra]
gen ll lr rl rr la ra = dupFlip (max (la + ll) (rl-ra), max (ra + rr) (lr-la))
dupFlip (x,y) = [(x,y), (y,x)]
perm [] = []
perm ] = [[]
perm (x:xs) = [ take i y ++ (x:drop i y) | y <- perm xs, i <- [1..length xs]]

ICPC by Haskell

引き続きICPC2005 Regional, Tokyo の問題Cを Haskell で.サイコロの全パタン生成が一番面倒かも.全盛生後の比較の高速化のために色名を数字に置き換える部分は少々手抜きかも.

 -- Problem C in ACM/ICPC 2005 ASIA Regional Tokyo
 -- 2005/11/04   Brute Force (24^3)
import Control.Monad
import Debug.Trace
import List
main = getProblems >>= mapM_ (putStrLn.show.solve)
 
getProblems = 
    do
    [n] <- getNums
    if n==0 then return []
       else do
            xs <- replicateM n getEntry
            liftM (xs:) getProblems
    where 
    getEntry = liftM words getLine
    getNums = liftM (map read.words) getLine
 
solve::[[String]]->Int
solve [d] = 0
solve ds = let 
           tab = zip (nub.sort.concat $ ds) [1..]
           rep x = case (lookup x tab) of Just i -> i
           ds' = map (map rep) ds
           in foldl1 min.map cost.map (head ds':).prod.map genAll.tail $ ds'
cost = sum . map cost'. trans
cost' xs = length xs - longest (sort xs)
longest (h:ts) = foldl1 max.map snd $ scanl (\(x, c) y -> if y == x then (x, c+1) else (y, 1)) (h,1) ts
trans s] = map (\x -> [) xs
trans (xs:xss) = zipWith (:) xs $ trans xss
prod s] = map (\x->[) xs
prod (xs:xss) = concat.map (\x -> map (x:) (prod xss)) $ xs
 -- generate all dice equivalent to the die by rotation
genAll = concat . map rots2 . rots1
 -- rotations around an axis (the front surface is fixed)
rots2 [x1,x2,x3,x4,x5,x6] = [[x1,x2,x3,x4,x5,x6],
                             [x1,x3,x5,x2,x4,x6],
                             [x1,x5,x4,x3,x2,x6],
                             [x1,x4,x2,x5,x3,x6]]
 -- rotations to move each surface to the front
rots1 [x1,x2,x3,x4,x5,x6] = [[x1,x2,x3,x4,x5,x6],
                             [x2,x6,x3,x4,x1,x5],
                             [x3,x2,x6,x1,x5,x4],
                             [x4,x2,x1,x6,x5,x3],
                             [x5,x1,x3,x4,x6,x2],
                             [x6,x5,x3,x4,x2,x1]]

forall A

Haskell で forall A. A -> A 系の型を作ってみる.まずもっとも単純に.

let x = x

t を型変数として x :: t で,undef 以外の何者でもない気がする.

んで,次.

let f x = x

これで f :: t->t . id 関数なような.

続いて

let y f = f (y f)

これで y :: (t->t)->t . fixpoint 関数とうか Y コンビネータなような.

ついでに,

let g y z = if True then y else z

とすると g :: t->t->t になる.意味のある関数ではないが... さて,これ以降はどうなるのだろうか?

ついでなので,forall a,b,... . a -> b -> ... も作ろうとすると

let f x y = f x y

とかで引数の数を増やせばいくらでもいける.意味はないけど.意味のあるものってどれくらいあるんだろう? undef, id, fixpoint 以外に意味のあるのがあるか?

ふと思ったこと@DT上P244

live を逆さまにすると evil だなぁ.逆さまになる英単語って意識したことなかったので新鮮な感じだ.

ICPC by Haskell

ICPC2005 Regional, Tokyo の問題Bを Haskell で.queue を使ったシミュレーションだけど面倒だから一ターンごとにリスト生成...

 -- Problem B in ACM/ICPC 2005 ASIA Regional Tokyo
 -- 2005/11/04     Brute Force
import Control.Monad
import Debug.Trace
main = getProblems >>= mapM_ (putStrLn.show.solve)
  
getProblems = 
    do
    [m, c, n] <- getNums
    if (n==0 && m==0 && c==0) then return []
       else do
            xs <- replicateM n getEntry
            liftM ((m,c,n,xs):) getProblems
    where 
    getEntry = getNums >> getNums
    getNums = liftM (map read.words) getLine
  
 -- it's better to make each entry of ds the pair of it and its length 
solve (m,c,n,xs) = sl xs 0 (take m $ repeat [])
    where
    sl [] t _ = t
    sl ys t ds = let
                 (hs, ys') = unzip $ map (\x->(head x, tail x)) ys
                 (t', ds') = sl' ds hs
                 in sl (filter (not.(==[])) ys') (t'+t) ds'
    sl' ds = foldl searchOne (0,ds)
    searchOne (t, ds) x = let 
                          p = length $ takeWhile (not.or.map (==x)) ds 
                          ds' =if p<m then take p ds++[filter (not.(==x)) (ds!!p)]++drop (p+1) ds
                               else ds  
                          in insertOne (t+p+1) ds' x
    insertOne t ds x =
        if length (head ds) < c then (t+1, (x:head ds):tail ds)
        else let
             p = length $ takeWhile ((==c).length) ds 
             ds' = if p<m then take p ds++[x:(ds!!p)]++drop (p+1) ds
                   else ds
             p' = length $ takeWhile ((==c).length) ds'
             hds = head ds
             tds = tail ds
             q = p'-1
             tds' =if p'<m then take q tds++[last hds:(tds!!q)]++drop (q+1) tds
                   else tds
             in (t+p+p'+p+5, (x:init hds):tds')
«Prev || 1 | 2 | 3 |...| 866 | 867 | 868 |...| 925 | 926 | 927 || Next»
Search
Feeds

Page Top