Haskellで文字列圧縮(エンコーダーのみ）

仕組み

  • 各文字の出現頻度を数えて一番多いものに"1"、二番目に"01"、三番目に"001"を割り振る。
  • ex "aaaaaaaaaaaa" -> "11111111111"
  • その後6ビットずつに区切る
  • ex "11111111111" -> ["111111","111111"]
  • 2進数として読み、文字に変換する
  • ex ["111111","111111"] -> "``"

動作例

Main> compress "aaaaaaaaaaaaabbbbbbbbbbbbbb"
Just "KKKK_`0"
Main> compress "qwerrfvghhvjnbknjkfaghjgfjda"
Just "!1!%!%%%B5B\"#!)A!$)#1;C\"!#1"

課題

文字の種類が多いものはうまく圧縮できない。
生成したビット列の長さが6で割りきれないときは勝手に0を補っている。
返り値が Maybe String 。
デコーダがない。（致命的）

ソースコード

import Data.Map as M
import Data.List
import Data.Char

allChar = Prelude.map chr [0..127]

genDict str = fromList $ Prelude.map func $ zip [1..] $ Prelude.map snd $ reverse $ sort $ zip (Prelude.map (countChar str) allChar) allChar
	where 
		func (a,b) = (b,makeCodeLengthN a)
		makeCodeLengthN 1 = "1"
		makeCodeLengthN n = '0' : makeCodeLengthN (n-1)
		countChar [] _ = 0
		countChar (x:xs) c = if x==c
			then 1 + countChar xs c
			else countChar xs c

translate [] d = return []
translate (x:xs) d = do
	y <- M.lookup x d
	ys <- translate xs d
	return (y++ys)

bitToChar str = func (reverse str) 0
	where
		func [] a = chr (33+a)
		func (x:xs) a = if x=='1'
			then func xs (a*2+1)
			else func xs (a*2)

split6 str = if length str < 6
	then [str]
	else fst (splitAt 6 str) : split6 (snd (splitAt 6 str) )

compress str = do
	a <- translate str $ genDict str
	return ( Prelude.map bitToChar (split6 a) )

std::setでデータ同士の間に順位付けができないと無視されてしまう件 

#include <stdio.h>
#include <set>
using namespace std;
struct Data{
	int a,b;
};
Data makeD(int aa,int bb){
	Data d;
	d.a=aa,d.b=bb;
	return d;
}
bool operator < (const Data &d,const Data &e){
	return d.a<e.a;
}
int main(){
	set<Data> se;
	se.insert(makeD(0,1));
	se.insert(makeD(0,2));
	printf("se.size()==%d\n",se.size());
	for(set<Data>::iterator it=se.begin();it!=se.end();it++)
		printf("a=%d b=%d\n",(*it).a,(*it).b);
	return 0;
}

を実行すると

se.size()==1
a=0 b=1

となってしまう。
これはsetが(0,1)と(0,2)の違いを分からないからである。

se.size()==2
a=0 b=1
a=0 b=2

このようにするには

bool operator < (const Data &d,const Data &e){
        if(d.a==e.a)           //<=
               return d.b<e.b; //<=
	return d.a<e.a;
}

こんな風に書き換えると良い。

HaskellでBrainfuckの処理系を実装する

Brainfuckとは

プログラムの動かし方

課題

'.' ポインタが指す値を出力に書き出す。C言語の「putchar(*ptr);」に相当。

IOモナドを使いたくない(使えない）のでマシン状態の中にディスプレイを作って処理した。

',' 入力から1バイト読み込んで、ポインタが指す先に代入する。C言語の「*ptr=getchar();」に相当。

複雑になりそうだったので実装しなかった。

-- Brainfuck.hs
import Data.Char

main = do 
    cs <- getContents
    putStrLn $ runBrainfuck cs
runBrainfuck p = display $ runOneStep $ Machine p 0 [0,0..] 0 ""
runOneStep (Machine a b c d e) = if (length a) == b then Machine a b c d e
                                                    else runOneStep $ incrementProgramPointer func
    where func = case (a!!b) of
                    '>' -> incrementPointer (Machine a b c d e)
                    '<' -> decrementPointer (Machine a b c d e)
                    '+' -> incrementMemory (Machine a b c d e)
                    '-' -> decrementMemory (Machine a b c d e)
                    '.' -> putCharToDisplay (Machine a b c d e)
                    ']' -> jumpEnd (Machine a b c d e)
                    '[' -> jumpStart (Machine a b c d e)
                    otherwise -> (Machine a b c d e)
incrementProgramPointer (Machine a b c d e) = Machine a (b+1) c d e
data Machine = Machine { program::String,programPointer::Int,memory::[Int],memoryPointer::Int,display::String   }
    deriving Show 
incrementPointer (Machine a b c d e) = Machine a b c (d+1) e
decrementPointer (Machine a b c d e) = Machine a b c (d-1) e
putCharToDisplay (Machine a b c d e) = Machine a b c d (e++[chr (c!!d)])
incrementMemory (Machine a b c d e) = Machine a b (changeMemory c 0 d (+ 1))d e
decrementMemory (Machine a b c d e) = Machine a b (changeMemory c 0 d (subtract 1))d e
jumpStart (Machine a b c d e) = if (c!!d)==0 then Machine a (func 0 b) c d e
                                             else Machine a b c d e 
    where func depth pos = case (a!!pos) of
                            '[' ->  func (depth+1) (pos+1)
                            ']' ->  if depth==1 then pos
                                                else func (depth-1) (pos+1)
                            otherwise   -> func depth (pos+1)
jumpEnd (Machine a b c d e) = if(c!!d)==0 then Machine a b c d e
                                          else Machine a (func 0 b) c d e
    where func depth pos = case (a!!pos) of
                            '[' ->  if depth==1 then pos
                                                else func (depth-1) (pos-1)
                            ']' -> func (depth+1) (pos-1)
                            otherwise   -> func depth (pos-1)
changeMemory [] i k f = []
changeMemory (x:mem) i k f = if i==k    then f x:mem
                                        else x:changeMemory mem (i+1) k f