M.Suzuki

漢数字で九九の表 (Nested Flatten)
基本的な数字を作ってから・・・なので、目新しさはありません。
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
k = ["一","二","三","四","五","六","七","八","九"]
ku = "  ":k
kl = "〇":k

main = putStrLn $ concat [str (x*y) | x <- [one..nine] ,y <- [one-one..nine]]
    where
        one = ten - nine
        nine = length k
        ten = length ku
        str n
            | n < one   = "\n"
            | otherwise = "  " ++ ku!!u ++ kl!!l
            where
                (u,l) = divMod n ten
タブ区切りデータの処理 (Nested Flatten)
あまり美しくないですが、基本に忠実に。
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
import System.Environment
import Data.List

q1 (x:xs) = x:sortBy (\a b -> compare (toNum a) (toNum b)) xs
    where
        toNum n = read (head n)::Int
q2 = map (\[i,l,f,a] -> [i,f,l,a])
q3 (x:xs) = x:map (\[i,l,f,a] -> [i,l,f,show $ 1+read a]) xs

main = do
    args <- getArgs
    contents <- if (not.null) args
        then readFile $ head args
        else getContents
    let rec = map words $ lines contents
    putStrLn $ shows $ q1 rec
    putStrLn $ shows $ q2 rec
    putStrLn $ shows $ q3 rec
    where
        shows list = unlines $ map (concat.intersperse "\t") list
lessの実装 (Nested Flatten)
IOまみれですが、なんとか実装しました。
ライブラリを使えば楽勝と思いきや、必要な機能が無かったり、
画面サイズを超えるとエラーになったりと、意外と手間取り、
検索機能を入れる前に、力尽きてしまいました。
  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
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
{-# LANGUAGE ForeignFunctionInterface #-}

--
--  ghc --make hless.hs -lncurses
--
--  need : hscurses-1.3

import System.IO
import Control.Exception
import System.Environment
import qualified UI.HSCurses.Curses as Curses
import qualified UI.HSCurses.CursesHelper as CursesH

import Foreign
import Foreign.C.Types

--

foreign import ccall unsafe "ncurses.h winsdelln"
    winsdelln :: Curses.Window -> CInt -> IO CInt

deleteln :: Int -> IO CInt
deleteln n = winsdelln Curses.stdScr $ fromIntegral (-n)

insertln :: Int -> IO CInt
insertln n = winsdelln Curses.stdScr $ fromIntegral n

--
data File = File {
    fhandle ::  Handle,
    list    ::  [Integer]
} deriving (Show)

data Info = Info {
    file    ::  File,
    top     ::  Int
} deriving (Show)

--
scanFile :: Handle -> IO [Integer]
scanFile fp = do
    eof <- hIsEOF fp
    if eof
        then return []
        else do
            p <- hTell fp
            l <- hGetLine fp
            flist <- scanFile fp
            return (p : flist)

showLine :: File -> Int -> IO String
showLine f n
    | n >= (length $ list f)    = do return "~"
    | otherwise             = do
        hSeek (fhandle f) AbsoluteSeek $ (list f)!!n
        line <- hGetLine $ fhandle f
        return line
--

getW = do
    (_,w) <- Curses.scrSize
    return w

getH = do
    (h,_) <- Curses.scrSize
    return h

drawLine :: Info -> Int -> IO ()
drawLine info n = do
    str <- showLine (file info) (n + (top info))
    ss <- trim str
    Curses.mvWAddStr Curses.stdScr n 0 ss
    where
        trim s = do
            w <- getW
            if (length s) >= w
                then
                    return ((take (w-2) s) ++ "$")  -- (x_x)
                else
                    return s

redraw :: Info -> IO ()
redraw info = do
    h <- getH
    redraw' h
    Curses.refresh
    where
        redraw' 0 = return ()
        redraw' n = do
            m <- getH
            drawLine info (m-n)
            redraw' (n-1)

--

moveDown :: Info -> IO Info
moveDown info
    | (top info) >= len =   return info
    | otherwise         =   scrollUp
    where
        len = length $ list $ file info
        next = info { top = (top info) + 1 }
        scrollUp = do
            h <- getH
            CursesH.gotoTop
            deleteln 1
            Curses.move (h-1) 0
            drawLine next (h-1)
            Curses.refresh
            return next

moveUp :: Info -> IO Info
moveUp info
    | (top info) == 0   =   return info
    | otherwise         =   scrollDown
    where
        next = info { top = (top info) - 1 }
        scrollDown = do
            CursesH.gotoTop
            insertln 1
            drawLine next 0
            Curses.refresh
            return next

eventLoop :: Info -> IO Info
eventLoop info =
    do
        key <- Curses.getCh
        case key of
            Curses.KeyChar 'l' -> process $ return info
            Curses.KeyChar 'q' -> return info
            Curses.KeyChar 'n' -> process $ moveDown info
            Curses.KeyChar 'p' -> process $ moveUp info
            Curses.KeyUp       -> process $ moveUp info
            Curses.KeyDown     -> process $ moveDown info
            _ -> eventLoop info
        where
            process f = do
                r <- f
                eventLoop r

--

main = do
    (fileName:_) <- getArgs
    fp <- openFile fileName ReadMode
    flist <- scanFile fp
    let info = Info { file = File { fhandle = fp, list = flist}, top = 0}
    runMain info `finally` CursesH.end
    where
        runMain info = do
            CursesH.start
            redraw info
            eventLoop info
2^i * 3^j * 5^k なる整数 (Nested Flatten)
軽く候補の絞込み(2と3と5の倍数しか回答は無いので)を入れてみました。
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
list max b n
    | (b^n) > max   =   []
    | otherwise = n : list max b (n+1)

scan n = [(n,i,j,k)|i<-list n 2 0,j<-list n 3 0,k<-list n 5 0,n == (2^i*3^j*5^k)]

result = take 100 $ concatMap (scan) $ filter (check) [1..]

check n
    | n == 1            =   True
    | (n `mod` 2) == 0  =   True
    | (n `mod` 3) == 0  =   True
    | (n `mod` 5) == 0  =   True
    | otherwise         =   False

main=do
    mapM (\x-> putStrLn $ format x) result
    where
        format (n,i,j,k) = concat [show n," = ",fmt 2 i," * ",fmt 3 j," * ",fmt 5 k]
        fmt b n = show b ++ "^" ++ show n
起動オプションの解析 (Nested Flatten)
少々無理矢理な感じです。。。Parsecが使えたらもっと楽なのでしょうね(^^;
 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
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
data Args = Args {
    outputFlag :: Bool,
    quoteFlag :: Bool,
    debugLevel :: Int,
    names :: [String]
} deriving (Show)

newArgs =   Args {
        outputFlag = False,
        quoteFlag = False,
        debugLevel = 0,
        names = []
    }

parse [] result = result

parse (arg:args) result
    | arg == "-d"       = parse (tail args) result{ debugLevel = read $ head args }
    | opt == "-d"       = parse args result{ debugLevel = read num }
    | (head arg) == '-' = parse args $ parse' (tail arg) result
    | otherwise         = parse args result{ names = (names result) ++ [arg] }
    where
        (opt,num) = splitAt 2 arg
        parse' [] res = res
        parse' ('o':xs) res = parse' xs res{ outputFlag = True }
        parse' ('q':xs) res = parse' xs res{ quoteFlag = True }
        parse' _ _ =    error $ arg ++ " is unknown option."

optParse :: [String] -> Args
optParse args
    | (outputFlag result) == False  =   error "-o is need option."
    | (names result) == []  =   error "need file name."
    | otherwise     =   result
    where
        result = parse args newArgs

dump args = do
    putStrLn "[Option information]"
    putStrLn $ "o(output) : " ++ (onoff $ outputFlag args)
    putStrLn $ "q(quote) : " ++ (onoff $ quoteFlag args)
    putStrLn $ "d(debug) : " ++ (show $ debugLevel args)
    putStrLn ""
    putStrLn "[Paramater information]"
    putStrLn $ "count : " ++ (show $ length $ names args)
    mapM (\(no,name)->putStrLn $ (show no) ++ " : " ++ name) $ zip [1,2..] $ names args
    putStrLn ""
    where
        onoff True = "ON"
        onoff _ = "OFF"

main = do
    args <- getArgs
    dump $ optParse args
{--
    mapM_ test testData
    mapM_ dumps testData
    where
        dumps arg = dump $ optParse arg
        test arg = putStrLn $ show $ optParse arg
        testData = map words ["-o AAA",
                    "-o AAA BBB CCC",
                    "-oq AAA",
                    "-o -q AAA",
                    "-o -d1 AAA",
                    "-o -d 1 AAA",
                    "-q -d2 -o AAA"]
--}
文字列型日時ののN秒後時間取得 (Nested Flatten)
なんの工夫もないコードです。
1
2
3
4
5
6
7
import Data.Time

addDate time sec = show $ addUTCTime sec $ read time

main = do
    putStrLn $ addDate "2008-09-02 10:20:30 UTC" 15
    putStrLn $ addDate "2008-09-02 10:20:30 UTC" (-5)
LL Golf Hole 7 - バイト数を読みやすくする (Nested Flatten)
内包表現を使用して空白を詰めると73Byte
1
toMan n = last [(show $ n/1024^x) ++ [y] | (x,y) <- zip [0,1..] " kMGTPEZY", n>=1024^x]
LL Golf Hole 8 - 横向きのピラミッドを作る (Nested Flatten)
がんばって53Byte
1
main=mapM(\x->putStrLn$replicate(4-abs x)'*')[-3..3]
LL Golf Hole 7 - バイト数を読みやすくする (Nested Flatten)
バイト数との事なので。。。
スペースと改行を詰めて101Byte
1
2
3
toMan n = snd $ last $ filter (\x -> n>fst x)
    $ map (\(x,y) -> (1024^x,(show $ n/1024^x) ++ [y]))
    $ zip [0,1..] " kMGTPEZY"
もうちょっと短くなりますね。
1
2
3
toMan n = snd $ last $ filter (\x -> n>fst x)
        $ map (\(x,y) -> (10^x,(show $ n/10^x) ++ [y]))
        $ zip [0,3..] " kMGTPEZY"
全部作ってから判断すると言う素直(富豪?)な実装。
1
2
3
4
5
6
toMan n = snd $ head $ reverse $ filter (\(x,y) -> n>x)
        $ map (\(x,y) -> (10**x, (show (n / (10**x))) ++ y))
        $ zip [0,3.0..] ["","k","M","G","T","P","E","Z","Y"]

main = do
    putStrLn $ toMan 1234567890123456789012345678901
LL Golf Hole 6 - 10進数を2進数に基数変換する (Nested Flatten)
なんか同じような定義があっていまいちです。。。
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
toChar n = (['0'..'9']++['A'..'Z']++['a'..'z'])!!n

toStr 0 _ = "0"
toStr n b = toStr' n b
    where
        toStr' 0 _ = ""
        toStr' n b = toStr' (n `div` b) b ++ [toChar (n `mod` b)]

main = do
    putStrLn $ toStr 0 10
    putStrLn $ toStr 255 2
    putStrLn $ toStr 255 10
    putStrLn $ toStr 255 16
    putStrLn $ toStr 255 32
LL Golf Hole 3 - 13日の金曜日を数え上げる (Nested Flatten)
方法は、各年の全月の13日が金曜日か調べるだけです。
が、目的の日付の曜日を調べる手軽な手段を見つけられなかったので、
ClockTime と CalendarTime を相互変換して、
 曜日を得るために addToClockTime すると言う、なんか変な事になっています。
 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
29
module Main (main) where
import Time
import Control.Monad
import System.IO.Unsafe

crossProduct :: [a] -> [b]-> [(a,b)]
crossProduct = liftM2 p
    where
        p x y = (x,y)

isJason :: (Int,Int) -> Bool
isJason (year,month) = week == Friday
    where
        mon = toEnum (month-1) :: Month
        clock = toClockTime $ CalendarTime year mon 13 0 0 0 0 Sunday 0 "JST" 9 False
        time = addToClockTime (TimeDiff 0 0 0 0 0 0 0) clock
        week = ctWDay $ unsafePerformIO $ toCalendarTime time

isAfter :: CalendarTime -> (Int,Int) -> Bool
isAfter cal (year,month) =
    year > ctYear cal || month > (fromEnum $ ctMonth cal) || 13 <= ctDay cal

main :: IO ()
main = do
    time <- getClockTime
    cal <- toCalendarTime time
    putStrLn $ show $
        filter (isAfter cal) $
        filter (isJason) $ crossProduct [(ctYear cal)..2013] [1..12]
lessの実装 (Nested Flatten)
効率はともかく、巨大なファイルでも表示できるように作ってみました。 表示はcurses、ファイルの行インデックススキャンをバックグラウンドで行うためにpthreadを使用しています。 行インデックスもテンポラリファイルとして書き出しているので、fpos_tが32bitの環境でも2GB、64bitなら8EBまでいける(自信なし)はずです。 ただし、システム側に懲りすぎたので、タブやら一行の折り返しやらは手を抜いて全く手付かずです。 検索機能もUIが手抜きのためインクリメンタルサーチしかできません。
  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
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
/*
    Large less
        programed by M.Suzuki
        ver 0.1     2008/8/4

    key binding
        n,j,^n      scroll up
        p,k,^p      scroll down
        /           i-search
        ESC         i-search cancel
        TAB         next search(i-search only)
        q           quit
 */

#include <stdio.h>
#include <string.h>
#include <curses.h>
#include <pthread.h>

#define LINE_MAX    256     /* file text width max  */

#define False   0
#define True    (!False)

static pthread_mutex_t file_mutex;
static FILE* fileFp;
static FILE* seekFp;
static fpos_t lineTop;
static fpos_t lineMax;
static bool readMaxFlag;
static bool abortFlag;

static void ScanWait()
{
    pthread_mutex_lock(&file_mutex);
    while( lineTop + LINES >= lineMax ){
        static struct timespec time10ms = {0,10*1000*1000};
        pthread_mutex_unlock(&file_mutex);
        nanosleep(&time10ms,NULL);
        pthread_mutex_lock(&file_mutex);
        if( readMaxFlag ){
            break;
        }
    }   /* end of while */
    pthread_mutex_unlock(&file_mutex);
}

static char* ReadLine(int y, char* buff)
{
    char* text = NULL;

    ScanWait();
    pthread_mutex_lock(&file_mutex);
    if( lineTop + y + 1 < lineMax ){
        fpos_t offset = sizeof(fpos_t)*(lineTop+y);

        fsetpos(seekFp,&offset);
        fread(&offset,sizeof(fpos_t),1,seekFp);
        fsetpos(fileFp,&offset);
        if( fgets(buff,LINE_MAX,fileFp) ){
            text = buff;
        }
    }
    pthread_mutex_unlock(&file_mutex);
    return text;
}

static void DrawLine(int y)
{
    char* text;
    char buff[LINE_MAX+1];

    text = ReadLine(y,buff);
    if( text == NULL ){
        text = "~";
    }
    mvinsstr(y,0,text);
}

static void ViewAll()
{
    int y;

    erase();
    for(y=0;y<LINES;y++){
        DrawLine(y);
    }
}

static void RollUp()
{
    ScanWait();
    pthread_mutex_lock(&file_mutex);
    if( lineTop >= lineMax ){
        if( readMaxFlag ){
            pthread_mutex_unlock(&file_mutex);
            return;
        }
    }
    lineTop++;
    pthread_mutex_unlock(&file_mutex);
    move(0,0);
    deleteln();
    move(LINES-1,0);
    DrawLine(LINES-1);
    refresh();
}

static void RollDown()
{
    pthread_mutex_lock(&file_mutex);
    if( lineTop <= 0 ){
        pthread_mutex_unlock(&file_mutex);
        return;
    }
    lineTop--;
    pthread_mutex_unlock(&file_mutex);
    move(0,0);
    insdelln(1);
    DrawLine(0);
    refresh();
}

static void Search()
{
    char search[LINE_MAX];
    int len = 0;

    while(1){
        int key = getch();
        int y = 0;
        if( key == 0x1b ){
            break;
        }
        if( key == '\t' ){
            y = 1;
        } else {
            if( len < LINE_MAX ){
                search[len++] = key;
                search[len] = '\0';
            }
        }
        while(1){
            char buff[LINE_MAX+1];
            if( ReadLine(y,buff) == NULL ){
                return;
            }
            if( strstr(buff,search) ){
                pthread_mutex_lock(&file_mutex);
                lineTop += y;
                pthread_mutex_unlock(&file_mutex);
                ViewAll();
                break;
            }
            y++;
        }   /* end of while */
    }   /* end of while */
}

static void KeyLoop()
{
    ViewAll();
    while(1){
        int key = getch();
        if( key == 'q' ){
            break;
        }
        switch(key){
          case 'N'-'@':
          case 'n':
          case 'j':
            RollUp();
            break;
          case 'P'-'@':
          case 'p':
          case 'k':
            RollDown();
            break;
          case '/':
            Search();
            break;
        }   /* end of switch */
    }   /* end of while */
}

void* ScanThread(void* arg)
{
    fpos_t filePos;

    fgetpos(fileFp, &filePos);
    while(1){
        char buff[LINE_MAX+1];
        fpos_t fpos = sizeof(fpos_t)*lineMax;

        pthread_mutex_lock(&file_mutex);
        fsetpos(seekFp,&fpos);
        fwrite(&filePos,sizeof(fpos_t),1,seekFp);
        lineMax++;
        fsetpos(fileFp,&filePos);
        if( fgets(buff,LINE_MAX,fileFp) == NULL ){
            break;
        }
        fgetpos(fileFp,&filePos);
        if( abortFlag ){
            break;
        }
        pthread_mutex_unlock(&file_mutex);
    }   /* end of while */
    readMaxFlag = True;
    pthread_mutex_unlock(&file_mutex);
    return NULL;
}

static void MainLoop()
{
    pthread_t scanThread_id;
    char tmpName[L_tmpnam];

    tmpnam(tmpName);
    if( (seekFp=fopen(tmpName,"w+b")) == NULL ){
        perror(tmpName);
        return;
    }

    pthread_mutex_init(&file_mutex,NULL);

    lineTop = 0;
    lineMax = 0;
    if( pthread_create(&scanThread_id,NULL,ScanThread,NULL)!=0){
        perror("ScanThread");
        return;
    }

    initscr();
    noecho();
    raw();
    cbreak();

    KeyLoop();

    nocbreak();
    noraw();
    echo();
    endwin();

    pthread_mutex_lock(&file_mutex);
    abortFlag = True;
    pthread_mutex_unlock(&file_mutex);
    pthread_join(scanThread_id,NULL);

    fclose(seekFp);
    remove(tmpName);
}

int main(int argc, char* argv[])
{
    char* fname = NULL;
    int i;

    for(i=1;i<argc;i++){
        char* p = argv[i];
        if( *p == '-' ){
            /* option   */
        } else {
            fname = argv[i];
        }
    }   /* end of for */
    if( fname != NULL ){
        if( (fileFp=fopen(fname,"r")) == NULL ){
            perror(fname);
            return 1;
        }
        MainLoop();
        fclose(fileFp);
    }
    return 0;
}
ワーカスレッドを安全に終了させるまで待機 (Nested Flatten)
「スレッドプールを作り、スレッドを待機させてから、リクエストを投げて結果を全て受け取る」と言う要求と受け取りました。 このプログラムでは、スレッドプールは残るようになっています。
 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
29
30
31
32
33
34
35
36
37
38
#
#   Thread pool
#
  
require 'thread'
  
THREADS = 5
  
cmd_queue = Queue.new
result_queue = Queue.new
thread_list = []
  
puts 'Thread start'
  
(0..THREADS).each do | no |
  thread_list << Thread.new(no) do | no |
    puts "Thread #{no} start"
    while cmd = cmd_queue.pop
      puts "Thread #{no} execute to #{cmd}"
      sleep rand(10)+5
      puts "Thread #{no} finished"
      result_queue.push("#{no}")
    end
  end
end
  
puts 'Execute start'
(0..THREADS).each do | no |
  cmd_queue.push("cmd #{no}")
end

puts 'Waitting execute'
(0..THREADS).each do
  no = result_queue.pop
  puts "Result #{no}"
end

puts 'All complete'
すべて置換 (Nested Flatten)
なんかもっとシンプルに書けそうな気もするのですが。。。
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
--
--  文字列の置き換え
--
  
module Main where
  
import Data.List
  
replace :: String -> String -> String -> String
replace _ _ "" = ""
replace "" _ all = all
replace inp out all@(s:ss)
    | isPrefixOf inp all    = out ++ replace inp out (drop (length inp) all)
    | otherwise             = s : replace inp out ss
  
main = do
    putStrLn $ show $ replace "abc" "ABC" "abcdefgabcdefg"
固定長データ (Nested Flatten)
敢えて冗長な書き方でやってみました。 メンテナンス性を考慮したつもりなんですが、見やすいかどうかは微妙です。
 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
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64