全部で実は88問だそうなので半分超えたくらいでしょうか。
（追記はじまり）
こんなあほなことで追記するとは、、、
半分超えたのではなくてちょうど半分まで来たのでした。
Prelude> [1..10] ++ [11..20] ++ [21..28] ++ [31..41] ++ [46..50]
[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,31,32,33,34,35,36,37,38,39,40,41,46,47,48,49,50]
Prelude> length it
44
（追記おわり）
H-99: Ninety-Nine Haskell Problemsより [46..50]、になります。
以下が今までの軌跡です。
99 Haskell Problems より、[1..10]
99 Haskell Problems より、[11..20]
99 Haskell Problems より、[21..28]
99 Haskell Problems より、[31] でもその前に
99 Haskell Problems より、[31..41]
46. 論理演算の実装、あと二変数のBoolean 関数の入力と出力の表を出せ。
IO () が絡むところがめんどくさいですね、これは解答からの受け売りですが。
Boolean の実装は簡単だと思います、例えばimpl などは色々書き方ありますが私は生で対応を網羅した形にしました。
table の実装は解答を見ました、色々考えて
-- It does not work.
table = do
a <- [True, False]
...
などとして最後に出力させようと思いましたが、網羅的にどう書くのだろう？となって止まったので諦めました。
mapM_ 使ってリストの中身全部にputStrLn を作用させるのは、これを見た後だもこれ以外思いつかないですね、自然です。
ただ、リストもモナドなのでdo 記法で書けるとは思いますが、、、
Prob46.lhs
> module Prob46 where
Define predicates and/2, or/2, nand/2, nor/2, xor/2, impl/2 and equ/2 (for logical equivalence) which succeed or fail according to the result of their respective operations; e.g. and(A,B) will succeed, if and only if both A and B succeed.
A logical expression in two variables can then be written as in the following example: and(or(A,B),nand(A,B)).
Now, write a predicate table/3 which prints the truth table of a given logical expression in two variables.
> table (\a b -> (and' a (or' a b)))
True True True
True False True
False True False
False False False
> infixl 4 `or'`
> infixl 4 `nor'`
> infixl 5 `xor'`
> infixl 6 `and'`
> infixl 6 `nand'`
> infixl 3 `equ`
> and', or' :: Bool -> Bool -> Bool
> and' True True = True
> and' _ _ = False
> or' False False = False
> or' _ _ = True
> not' :: Bool -> Bool
> not' True = False
> not' False = True
>
> nand', nor' :: Bool -> Bool -> Bool
> nand' a b = not' (and' a b)
> nor' a b = not' (or' a b)
> xor' :: Bool -> Bool -> Bool
> xor' a b = (a /= b)
> -- (==>)
> impl :: Bool -> Bool -> Bool
> True `impl` b = b
> False `impl` _ = True
> equ :: (Bool -> Bool) -> (Bool -> Bool) -> Bool
> equ bf1 bf2 = foldr and' True [bf1 x == bf2 x| x <- [True, False]]
*Prob46> equ not' (not' . not' . not')
True
*Prob46> equ id (not' . not')
True
*Prob46> :t print
print :: Show a => a -> IO ()
*Prob46> print True
True
*Prob46> :t show
show :: Show a => a -> String
*Prob46> show True ++ " " ++ show False
"True False"
*Prob46> putStrLn $ show True ++ " " ++ show False
True False
> table :: (Bool -> Bool -> Bool) -- Boolean function
> -> IO ()
> table bf = mapM_ putStrLn
> [ show a ++ " " ++ show b ++ " " ++ show (bf a b)
> | a <- [True, False], b <- [True, False]]
47. 関数ではなくて演算子でand, or などを書け。
Haskell では $`$ で囲ってあげたら二変数関数は演算子化できるので簡単です。
それだけですね。
Prob47.lhs
> module Prob47 where
Truth tables for logical expressions (2).
Continue problem P46 by defining and/2, or/2, etc as being operators.
This allows to write the logical expression in the more natural way, as in the example: A and (A or not B).
Define operator precedence as usual; i.e. as in Java.
> import Prob46
> table2 :: (Bool -> Bool -> Bool) -- Boolean function
> -> IO ()
> table2 bf
> = mapM_ putStrLn
> [ show a ++ " " ++ show b ++ " " ++ show (bf a b)
> | a <- domain, b <- domain]
> where domain = [True, False]
48. 一般的なn 変数のBoolean 関数について真理表を出力せよ。
これは難しかった、、、
n が与えられるので再帰で書けるはずと当たりは付きますが、入力の真理表と結果を再帰的にどう繋いだらいいかわからず断念しました。
基本的にはmapM_ でもってputStrLn をほしいものリストに作用させていくアイティアで、あとはほしいものリストを完成させたら良いわけです。
模範解答はreplicateM の使い方がミソで、これで入力の真理表が完成できます。
あとはその入力に対する出力をshow に食べさせたら良いわけです。
個人的にはtoStr の中の補助関数space で上手に整形するのは賢いなぁと思いました。
入力の真理表を作る補助関数を自前で作ってみたのがbTable です、(++) を使ったのでおそらく性能は悪いですね。
Prob48.lhs
> module Prob48 where
Truth tables for logical expressions (3).
Generalize problem P47 in such a way that the logical expression may contain any number of logical variables.
Define table/2 in a way that table(List,Expr) prints the truth table for the expression Expr, which contains the logical variables enumerated in List.
> tablen 3 (\[a,b,c] -> a `and'` (b `or'` c) `equ'` a `and'` b `or'` a `and'` c)
-- infixl 3 `equ'`
True True True True
True True False True
True False True True
True False False True
False True True True
False True False True
False False True True
False False False True
-- infixl 7 `equ'`
True True True True
True True False True
True False True True
True False False False
False True True False
False True False False
False False True False
False False False False
> import Prob46
> import Control.Monad (replicateM)
Trial-generalized-boolean function:
> gbf :: [Bool] -> Bool
> gbf _ = True
> tableN :: Int
> -> ([Bool] -> Bool) -- generalized boolean function
> -> IO ()
> tableN n f = mapM_ putStrLn [toStr a ++ " => " ++ show (f a) | a <- args n]
> where
> args n = replicateM n [True, False]
> toStr = unwords . map (\x -> show x ++ space x)
> space True = " "
> space False = " "
To replace args n,
> bTable :: Int -> [[Bool]]
> bTable 0 = []
> bTable 1 = [[True], [False]]
> bTable n = map (True:) rest ++ map (False:) rest
> where
> rest = bTable (n-1)
> tableN' :: Int
> -> ([Bool] -> Bool) -- generalized boolean function
> -> IO ()
> tableN' n f = mapM_ putStrLn [toStr a ++ " => " ++ show (f a) | a <- args n]
> where
> -- args n = replicateM n [True, False]
> args = bTable
> toStr = unwords . map (\x -> show x ++ space x)
> space True = " "
> space False = " "
49. n ビットのGray コード。
要は二進数の0 から2^n-1 までを出力したら良くて、ここまでの流れだとreplicateM を使うと思うのだけど、模範解答では再帰を生で書いてありました。
たとえ高階関数のfoldr を使っても（信頼性以外は）変わらないわけでパフォーマンスも違いなしですね。
Prob49.lhs
> module Prob49 where
Gray codes.
An n-bit Gray code is a sequence of n-bit strings constructed according to certain rules. For example,
> gray 3
["000","001","011","010","110","111","101","100"]
*Prob48 Control.Monad> replicateM 3 ['0','1']
["000","001","010","011","100","101","110","111"]
> import Control.Monad (replicateM)
> gray :: Int -> [String]
> gray n = replicateM n ['0','1']
> gray' :: Int -> [String]
> gray' 0 = [""]
> gray' n = foldr helper [] (gray (n-1))
> where helper s acc = ("0" ++ s) : ("1" ++ s) : acc
> gray'' :: Int -> [String]
> gray'' 0 = [""]
> gray'' n = [ '0' : x | x <- prev] ++ [ '1' : x | x <- prev]
> where prev = gray'' (n-1)
*Prob49> gray 10
(0.11 secs, 13,586,752 bytes)
*Prob49> gray' 10
(0.12 secs, 14,024,096 bytes)
*Prob49> gray'' 10
(0.12 secs, 13,997,720 bytes)
50. Huffman 符号。
（追記はじまり）
アルゴリズムの概要は英語のWikiがわかりやすいと思います、gif アニメもあっていいですね。
（追記終わり）
星３つだけあって苦労してます（これを書き始めた時はまだHuffman 木までしか作れておりません、まぁあとはエンコーダーと木からリストを同時に再帰でやれば良さそうだなと当たりをつけている、という感じです。）
最初は色々考えました、Node とLeaf の数の比較を円滑にするためMaybe でChar をくるんでしまおうとか。
結局Int を吐く関数weight を書いたらそれで済むと思いついたので木構造は普通の二分木に落ち着きました。
ここではsortByFreq を入力に対するソートとしてクイックソートを採用しまして、fromList の中でのsort' は一回の挿入だけ行うので別に用意した感じです。
まずconverter ですべてLeaf に焼き直した後、昇順なのを利用して前から木構造に畳み込んでいきます、Node が出てくるたびにweight で取ってきたInt によってソートしなおして、最後シングルトンリストになったら外に出すという実装です。
あとはこの途中段階のHuffman 木をリストに畳み込みつつ”翻訳”していけばよいわけです、本質的な実装はhuffman' で行っています。
最後に整形するためにアルファベットごとにソートしなおして（いらないかもしれませんが）目的の関数が完成します。
あまり美しい実装ではないですし、where の中でwhere というのはなんとなく避けたほうが良さそうな気がするのですが、とりあえず書けました。
Prob50.lhs
> module Ptob50 where
Huffman codes.
We suppose a set of symbols with their frequencies, given as a list of fr(S,F) terms.
Example: [fr(a,45),fr(b,13),fr(c,12),fr(d,16),fr(e,9),fr(f,5)].
Our objective is to construct a list hc(S,C) terms, where C is the Huffman code word for the symbol S.
In our example, the result could be Hs = [hc(a,'0'), hc(b,'101'), hc(c,'100'), hc(d,'111'), hc(e,'1101'), hc(f,'1100')] [hc(a,'01'),...etc.].
The task shall be performed by the predicate huffman/2 defined as follows:
> huffman [('a',45),('b',13),('c',12),('d',16),('e',9),('f',5)]
[('a',"0"),('b',"101"),('c',"100"),('d',"111"),('e',"1101"),('f',"1100")]
see
http://www.snap-tck.com/room03/c02/comp/comp032.html
> data HTree a -- Huffman tree
> = Leaf (a, Int)
> | Node Int (HTree a) (HTree a)
> deriving (Show)
> sortByFreq :: [(a, Int)] -> [(a, Int)]
> sortByFreq [] = []
> sortByFreq ((c,n):rest) = smaller ++ ((c,n):greater)
> where -- For input, quick sort
> smaller = sortByFreq [(d,m) | (d,m) <- rest, m <= n]
> greater = sortByFreq [(d,m) | (d,m) <- rest, m > n]
> converter :: [(a, Int)] -> [HTree a]
> converter lst = map toLeaf lst
> where
> toLeaf :: (a, Int) -> HTree a
> toLeaf (c,n) = Leaf (c,n)
*Ptob50> sortByFreq [('a',45),('b',13),('c',12),('d',16),('e',9),('f',5)]
[('f',5),('e',9),('c',12),('b',13),('d',16),('a',45)]
*Ptob50> converter it
[Leaf ('f',5),Leaf ('e',9),Leaf ('c',12),Leaf ('b',13),Leaf ('d',16),Leaf ('a',45)]
> weight :: HTree a -> Int
> weight (Leaf (c,n)) = n
> weight (Node n _ _) = n
> fromList :: [(a,Int)] -> HTree a
> fromList = fromList' . converter . sortByFreq
> fromList' :: [HTree a] -> HTree a
> fromList' [l1,l2] = Node (n1+n2) l1 l2
> where -- They are sorted.
> n1 = weight l1
> n2 = weight l2
> fromList' (l1:l2:rest)
> = fromList' $ sort' ((fromList' [l1,l2]) : rest)
> where
> sort' :: [HTree a] -> [HTree a]
> sort' [] = []
> sort' (l1':rest) = sm ++ (l1':gt)
> where -- They are already sorted, so just insert our pivot.
> sm = [l | l <- rest, weight l <= weight l1']
> gt = [l | l <- rest, weight l > weight l1']
We have a Huffman tree:
*Ptob50> fromList [('a',45),('b',13),('c',12),('d',16),('e',9),('f',5)]
Node 100 (Leaf ('a',45))
(Node 55 (Node 25 (Leaf ('c',12))
(Leaf ('b',13)))
(Node 30 (Node 14 (Leaf ('f',5))
(Leaf ('e',9)))
(Leaf ('d',16))))
> huffman' :: HTree a -> [(a,String)]
> huffman' (Leaf (c,_)) = [(c,"")]
> huffman' (Node _ (Leaf l1@(c1,_)) node2)
> = (c1, "0"):(map (helper '1') $ huffman' node2)
> huffman' (Node _ node1 (Leaf l2@(c2,_)))
> = (map (helper '0') $ huffman' node1) ++ [(c2,"1")]
> huffman' (Node _ node1 node2)
> = (map (helper '0') $ huffman' node1)
> ++ (map (helper '1') $ huffman' node2)
>
> helper :: Char -> (a, String) -> (a, String)
> helper n (c,nums) = (c, n:nums)
> huffman :: (Ord a) => [(a,Int)] -> [(a,String)]
> huffman = sortByA . huffman' . fromList . sortByFreq
>
> sortByA :: (Ord a) => [(a,b)] -> [(a,b)]
> sortByA [] = []
> sortByA (c:cs) = sm ++ (c:gt)
> where
> sm = sortByA [d|d <- cs, (fst d) < (fst c)]
> gt = sortByA [d|d <- cs, (fst d) > (fst c)]
>
*Ptob50> huffman [('a',45),('b',13),('c',12),('d',16),('e',9),('f',5)]
[('a',"0"),('b',"101"),('c',"100"),('d',"111"),('e',"1101"),('f',"1100")]