Showing posts with label haskell. Show all posts
Showing posts with label haskell. Show all posts

Monday, January 04, 2010

P07 กับ List Moand

เห็นน้องป้อทำโจทย์ P07 ของ Ninety-Nine Lisp Problem ก็เลยกลับไปอ่านวิธีทำของตัวเอง แล้วก็พบว่าถึงแม้เวลาจะผ่านมา 4 ปีแล้ว ตัวเองก็ยังไม่เคยเข้าใจคำตอบของ Conor McBride เลย วันนี้ก็เลยได้ฤกษ์ทำความเข้าใจกับ List Monad ที่ Conor ใช้ตอบคำถามผม

เริ่มด้วยคำอธิบาย Monad ที่บอกว่า Monad คือ "an abstract datatype of actions" ซึ่งมีนิยามง่ายๆแค่นี้
class Monad m where
(>>=) :: m a -> (a -> m b) -> m b
return :: a -> m a


มันคือ pattern ฉนั้นอย่าพึ่งไปพยายามจินตนาการว่า มันทำอะไรได้บ้าง
หันกลับมาดู context ของ List บ้าง เรารู้ว่า type ของ List คือ [a] จะเห็นว่า type [a] มันสามารถมองเป็น m a ได้ (เพราะ type constructor มันมี free variable 1 ตัวเหมือนกัน) ฉนั้นเราลองมา implement ให้ List เป็น Monad กัน

เริ่มจาก implementation ที่ง่ายที่สุดก่อน ก็คือ return, return มี type เป็น a -> m a ฉนั้นกรณีของ List, คำสั่ง return 4 ก็ควรได้ค่า [4] ออกมา
instance Monad [] where
return x = [x]

ตัวถัดมาก็คือ function >>= นิยามของ type มันคือ m a -> (a -> m b) -> m b
เปลี่ยน m a ให้เป็น [a] จะได้ [a] -> (a -> [b]) -> [b] จะเห็นว่า definition มันไกล้เคียงกับ map function ที่มี type เป็น [a] -> (a -> b) -> [b] ดังนั้นเราสามารถ implement >>= โดยใช้ map และ concat
หน้าตาออกมาดังนี้
instance Monad [] where
return x = [x]
xs >>= f = concat (map f xs)

ได้นิยามของ List ในมุมมองของ Monad ออกมาอย่างงงๆ
แล้วมันมีประโยชน์อะไรหล่ะ ที่ทำ List type ให้เป็น instance ของ Monad type

ลองมาหัดใช้ List Monad ทำโจทย์
ถ้าให้ list ของ [1..10] มาให้หาตัวเลข 2 ตัวที่ผลคูณมีค่า = 16

ถ้าใช้ List Monad ก็จะเขียนแบบนี้
guard True xs = xs
guard False xs = []

solve = do
x <- [1..10]
y <- [x..10]
guard (x * y == 16) (return (x,y))

ซึ่งมี form ที่ไกล้เคียงกับ solution ที่ใช้ List comprehension
[(x,y) | x <- [1..10], y <- [x..10], x * y == 16]

กลับมาที่ solution ที่ McBride เขียนตอบผม
flat1 :: Store a -> a
flat1 (E a) = return a
flat1 (S xs) = xs >>= flat1

ถึงตอนนี้พอจะรู้เรื่องกับคำอธิบายของเขาแล้ว
Your (flat xs) on a list of stores becomes my (xs >>= flat1), systematically lifting the operation on a single store to lists of them and concatenating the results. The return operation makes a singleton from an element. This way of working with lists by singleton and concatenation is exactly the monadic structure which goes with the list type, so you get it from the library by choosing to work with list types. In Haskell, when you choose a typed representation for data, you are not only choosing a way of containing the data but also a way to structure the computations you can express on that data

Related link from Roti

Thursday, January 22, 2009

cluster by

Tom MoerTel เขียน function มหัศจรรย์ไว้ใน post ClusterBy: a handy little function for the toolbox
function มีหน้าตาแบบนี้
import Control.Arrow ((&&&))
import qualified Data.Map as M

clusterBy :: Ord b => (a -> b) -> [a] -> [[a]]
clusterBy f = M.elems . M.map reverse . M.fromListWith (++)
. map (f &&& return)

แล้วก็ทำแบบนี้ได้
*Main> let antwords = words "the tan ant gets some fat"
*Main> clusterBy length antwords
[["the","tan","ant","fat"],["gets","some"]]
*Main> clusterBy head antwords
[["ant"],["fat"],["gets"],["some"],["the","tan"]]
*Main> clusterBy last antwords
[["the","some"],["tan"],["gets"],["ant","fat"]]

ตัว function กระทัดรัดมาก แต่อ่านแล้วไม่เข้าใจเลย ก็เลยต้องออกแรงนั่งแกะหน่อย
เริ่มแรกสุด มันจะทำแบบนี้ก่อน
map (f &&& return) ["the", "tan", "ant", "gets", "some", "fat"]

เจ้า &&& มีชื่อเรียกว่า fanout ลองดูการทำงานมัน (เพราะอธิบายยากมาก)
*Main> (head &&& last) "abc"
('a','c')
*Main> (head &&& id) "abc"
('a',"abc")

จะเห็นว่ามัน apply function แรกกับ function ที่ 2 เข้ากับ parameter ผลลัพท์ที่ได้ก็จับมาเข้าคู่เป็น tuple ไว้ (หรือจะเรียกว่า pair ก็ได้ เพราะมีแค่ 2 elements)
Note: ถ้าใครยังงงๆกับ fanout ลองดู diagram ที่ Daniel Lyons เขียนไว้ใน Haskell Arrows

ที่นี้มาลองดู return บ้าง การที่เราสั่ง return "abc" ผลลัพท์ของมันก็คือ Monad "abc"
(ถ้ายังไม่รู้จัก monad ก็ให้สมมติไปก่อนว่า monad ก็คือ container structure แบบหนึ่ง)
ดังนั้นผลลัพท์ของ

map (head &&& return) ["the", "tan", "ant", "gets", "some", "fat"]
ก็จะได้
[("t", Monad "the"), ("t", Monad "tan"), ...]


การทำงานลำดับถัดมาก็คือ M.fromListWith (++) หรือถ้าเขียนเต็มๆก็คือ Data.Map.fromListWith (++)
เจ้า fromListWith เป็น function ที่ไว้ใช้สร้าง Dictionary(Map) structure
โดยมันจะรับ array ของ pair (ในทีนี้ก็คือ [("t", M "the"), ("t", M "tan"), ...]) แล้วสร้างเป็น Map structure โดยใช้ element แรกของ pair เป็น key ส่วน element ที่สองก็เป็น value ไป
แต่เจ้า fromListWith มีความพิเศษตรงที่ว่า กรณีที่มันพบว่า first element นั้นซ้ำกับที่เคยมีอยู่แล้ว
มันก็จะ apply function ที่เราส่งเข้าไป (ในที่นี้ก็คือ (++)) ให้กับ value ทั้งสอง
ลองดูตัวอย่าง
fromListWith (++) [("a", "ant"), ("b", "bat"), ("a", "axe")]
จะได้ผลลัพท์เป็น
Map ที่มี 2 entry
entry แรกมี key เป็น "a" และ value เป็น "axeant"
ส่วน entry ที่สอง มี key เป็น "b" และ value เป็น "bat"

กรณีของเรา element ที่สองมันมี type เป็น Monad
เจ้า function (++) เมื่อเจอกับ Monad มันจะมีพฤติกรรมเป็นแบบนี้แทน
*Main> [1] ++ [2]
[1,2]
*Main> (return 1) ++ (return 2)
[1,2]
*Main> (return "ant") ++ (return "axe")
["ant","axe"]

Note: ดูเหมือนว่าใน haskell่, Array กับ Monad มีความสัมพันธ์แน่นแฟ้น

คำสั่งลำดับถัดไปก็คือ M.map reverse
อันนี้ไม่มีอะไรแล้ว แค่ reverse ค่า value ทุกตัวใน Map

สุดท้ายก็คือ elems ก็คือ กรองเอาแต่ค่า value ใน Map

Related link from Roti

Friday, October 17, 2008

Local Loop Expression ภาค 2

วันนี้เห็น code การบ้าน haskell ของ Porges
ตรงส่วนของการวน loop รับ entry ของ user
โดย user ต้องเลือก choice ว่าอยากให้โปรแกรมเป็น c(client) หรือ s(server)
โดย code มีหน้าตาแบบนี้

main = withSocketsDo $ do -- enable sockets under windows
putStrLn "Welcome to One-Way Chat version 1.0"
...
input <- untilM -- get input of 'c' or 's'
(\x -> (not $ null x) && toLower (head x) `elem` "cs")
(putStr "Client or server? " >> getLine)
...

ประเด็นที่ผมสนใจ ก็คือ การวนลูป รับค่าจาก user และตรวจสอบว่าเป็นค่าที่ถูกต้องไหม
ตรงนี้เขา define function ที่ชื่อ untilM เข้ามาช่วย
หน้าตาของ untilM
-- monadic `until`
untilM p x = x >>= (\y -> if p y then return y else untilM p x)

จะเห็นว่า untilM รับ arguments 2 ตัวคือ p(predicate) กับ x
โดยมันจะทำ x ก่อน
ผลลัพท์ที่ได้จะถูก test ด้วย p
ถ้าผ่าน ก็จะ return กลับมา ถ้าไม่ผ่านก็ recursive รับค่าต่อไป

เห็นแล้วก็นึกถึง Local loop expression ที่เคยเขียนถึง
ก็เลยลองจับ untilM มาเขียนใหม่ด้วย fix ได้หน้าตาแบบนี้ออกมา
import Control.Monad.Fix

main = do ...
...
input <- fix (\loop ->
do putStr "Client or server? "
l <- getLine
if head(l) `elem` "cs" then return l else loop)
...

ดูแล้วก็ยังไม่สวยถูกใจเท่าไรนัก

Related link from Roti

Monday, September 22, 2008

Local Loop Expression

เคยเขียนถึง Y combinator ไปที
ตอนนั้นก็ไม่เคยคิดว่า มันจะมีตัวอย่างการใช้งานในชีวิตจริง
วันนี้ได้เห็นตัวอย่างการนำไปใช้ ที่น่าสนใจ
โดยเขาเอามันมาทำ local loop expression
reader <- forkIO $ fix $ \loop -> do
(nr', line) <- readChan chan'
when (nr /= nr') $ hPutStrLn hdl line
loop

ในตัวอย่างข้างบน forkIO คือการแตก thread ออกไปทำงาน,
fix คือ function ที่ทำให้เกิด magic
โดยมันทำให้เราทำ recursive แบบไม่ต้องประกาศชื่อ function ได้
(ในตัวอย่าง loop ก็คือ function ที่ pass เข้ามา, ถ้าเราอยากให้มัน recursive ทำ ก็ให้เรียกมันซ้ำ)

ใน xmonad ที่เป็น window manager ที่เขียนด้วย haskell ก็มีใช้แบบนี้
โดยการทำงานก็คือการวน loop ตรวจสอบ windows event
f = fix $ \again -> do
more <- checkMaskEvent d enterWindowMask ev
when more again


เจ้า function fix มันอยู่ใน module Control.Monad.Fix
ซึ่งเกิดจาก paper นี้
ใครธาตุไฟแข็งแรงก็เข้าไปอ่านได้ครับ (ผมเปิดดูแล้วก็ปิดทันที)

Related link from Roti

Wednesday, March 19, 2008

Recursive streams (Haskell)

หลายคนคงเคยเห็นตัวอย่าง function ที่ทำหน้าที่หาค่า Fibonacci แบบ recursive ธรรมดามาแล้ว

fib 0 = 1
fib 1 = 1
fib n = fib(n-1) + fib(n-2)


ใน haskell มันมีเทคนิคตัวหนึ่งที่เรียกว่า recursvie stream
ซึ่งเราสามารถนำมา apply หาค่า Fibonacci ได้

fibs = 1:1:zipWith (+) fibs (tail fibs)

หลักการก็คือ ถ้าเราสังเกตุค่า Fib ดู

1 1 2 3 5 8 13 21 ... ค่า fib sequence
1 2 3 5 8 13 21 34 ... tail fib (function tail จะทำการตัดตัวหน้าสุดทิ้ง)

ทั้งสองบรรทัดข้างบนบวกกันได้
2 3 5 8 13 21 34 55
ซึ่งก็คือ tail of tail of fib sequence

เมื่อนำหลักการข้างบนมาเขียน function fibs
fibs ก็เลยเท่ากับ 1 ตาม ด้วย 1 และตามด้วย ค่า fib บวกด้วย tail ของ fib

แต่ Diagram ที่ช่วยให้ผมเห็นภาพได้ดียิ่งขึ้น ก็คือ diagram นี้



เป็น diagram ที่อยู่ในหนังสือ The Haskell School of Expression
ของ Paul Hudak

Related link from Roti

Friday, March 07, 2008

snail-shell

เมื่อวานนั่งเขียนโจทย์เกี่ยวกับ shell-snail ใน codenone ด้วย Haskell
แต่ใน codenone มันทำ syntax highlight ไม่ได้
ก็เลยมาขอฉายซ้ำใน blog อีกที

เริ่มจากโจทย์ก่อน
ให้เขียนโปรแกรมที่รับค่า N และนำมา plot graph ให้ได้ตามนี้

กรณี N=3
***
*
***

กรณี N=4
****
*
* *
****

กรณี N=5
*****
*
*** *
* *
*****

กรณี N=6
******
*
**** *
* * *
* *
******


คิดจะเขียนโปรแกรมด้วย Haskell ก็ต้องคิดแบบ recursive เป็นหลัก
จะเห็นว่าที่ dimension N ใดๆ จะมี sub picture ที่ (N-2) ซ้อนอยู่ในนั้นด้วย
แต่จะซ้อนอยู่ในลักษณะกลับหัวกลับหาง (คือ flip ทาง horizontal ที่หนึ่งก่อน แล้วค่อย flip ทาง vertical อีกที)

ลองดูรูป N=6 จะเห็นว่าเกิดจาก

N=4

****
*
* *
****

กลับหัวกลับหางเป็น

****
* *
*
****

แล้วนำไปซ้อนกับรูป พื้นฐาน ที่ N=6

******
*
*
*
*
******


ดังนั้น นิยามของรูปของเราก็คือ

รูป N = (รูป (N-2) กลับหัวกลับหาง) ซ้อนกับ รูปพื้นฐาน N

เขียนเป็น function ได้ว่า

pic n = (flip_all (pic n-2)) `over` base n


เนื่องจากโปรแกรมเราเป็น recursive ดังนั้นมันก็ต้องมี รูปที่เป็นจุดเริ่มต้นให้มันด้วย
ซึ่งในกรณีนี้ก็คือ N=1 และ N=2
pic 1 = ["*"]
pic 2 = ["**"," *"]
pic n = (flip_all (pic n-2)) `over` base n

นิยามของ base n ก็ง่ายๆนั่นคือ
เอา '****' มาประกบหัวและหางเข้ากับ ' *'
โดยมีความกว้างและความสูงเท่ากับค่า N
-- base 3 = ["***",
-- " *",
-- "***"]
--
-- base 4 = ["****",
-- " *",
-- " *",
-- "****"]
--
-- for n = 4
-- hbar = "****"
-- rbar = " *"
--
base n = [hbar] ++ (replicate (n-2) rbar) ++ [hbar]
where hbar = replicate n '*'
rbar = (replicate (n-1) ' ') ++ ['*']

function ถัดไปก็คือ flip_all
ซึ่งเกิดจาก flip_vertical compose กับ flip_horizontal
--
--render $ flip_horizontal $ pic 4
--
-- "****"
-- "* "
-- "* *"
-- "****"
flip_vertical = reverse
flip_horizontal = map reverse
flip_all = flip_vertical . flip_horizontal

function ที่ดูจะยุ่งยากสุด ก็คือ function ที่ใช้วางรูปซ้อนกัน
เพื่อความง่ายในการซ้อน เราเลยเพิ่ม helper function ที่ใช้ในการปรับขนาดรูปให้เท่ากันเสียก่อน
ก่อนที่จะนำมาซ้อนกัน
-- patch (base 3) 5 = ["     ",
-- " ",
-- "*** ",
-- " * ",
-- "*** "]
--
patch xs n = replicate diff blankline ++
[ x ++ (replicate diff ' ') | x <- xs]
where blankline = replicate n ' '
diff = n - (length xs)


-- ["****", [" ", ["****",
-- " *", over "*** ", => "****",
-- " *", "* ", "* *",
-- "****"] "*** "] "****"]
--
over xs ys = zipWith over' xs ys
where over' linex liney = zipWith over'' linex liney
over'' x y | x == ' ' = y
| otherwise = x

ปรับนิยาม pic ของเราให้ใช้ patch function ช่วยปรับขนาดก่อนวางทาบกัน
pic 1 = ["*"]
pic 2 = ["**"," *"]
pic n = (patch (flip_all $ pic (n-2)) n) `over` base n


ส่วนการ render นั้นมันมีเรื่อง IO มาเกี่ยวข้องด้วย
ก็ต้องใช้ function พวก mapM (M มาจาก Monad) เข้ามาช่วย
render n = do 
print $ "N = " ++ (show n)
mapM print (pic n)


ลองสั่ง run ดู
*Main> mapM render [1..8]
"N = 1"
"*"
"N = 2"
"**"
" *"
"N = 3"
"***"
" *"
"***"
"N = 4"
"****"
" *"
"* *"
"****"
"N = 5"
"*****"
" *"
"*** *"
"* *"
"*****"
"N = 6"
"******"
" *"
"**** *"
"* * *"
"* *"
"******"
"N = 7"
"*******"
" *"
"***** *"
"* * *"
"* *** *"
"* *"
"*******"
"N = 8"
"********"
" *"
"****** *"
"* * *"
"* * * *"
"* **** *"
"* *"
"********"

Related link from Roti

Thursday, February 07, 2008

haskell -> python -> ruby -> ...

วันนี้เจอโปรแกรม haskell เขียนโดย sigfpe


def q(a,b,c):print b+chr(10)+'q('+repr(b)+','+repr(c)+','+repr(a)+')'
q("def q(a,b,c):print b+chr(10)+'q('+repr(b)+','+repr(c)+','+repr(a)+')'","def e(x) return 34.chr+x+34.chr end;def q(a,b,c) print b+10.chr+'main=q '+e(b)+' '+e(c)+' '+e(a)+' '+10.chr end","q a b c=putStrLn $ b ++ [toEnum 10,'q','('] ++ show b ++ [','] ++ show c ++ [','] ++ show a ++ [')']")

ทายสิว่ามันทำอะไร
ลอง copy ไปใส่ file ชื่อ x.hs ดู
แล้วลอง run แบบนี้

$ runhaskell x.hs > x.py
$ python x.py > x.rb
$ ruby x.rb > y.hs

$ runhaskell y.hs > y.py
$ python y.py > y.rb
$ ruby y.rb > z.hs

... (ทำไปเรื่อยๆ จนกว่าจะเบื่อ)

Related link from Roti

Monday, January 28, 2008

Y combinator in BarcampBangkok

คำเตือน
post นี้อาจทำให้เกิด stack overflow ในสมองคนอ่านได้ (เหมือนที่เกิดกับคนเขียนไปแล้ว)

กลับจาก BarcampBangkok ด้้วยสมองอันหนักอื้ง
สิ่งหนึ่งที่ยังติดใจไม่หายก็คือ source code ของ Haskell หน้าตาแบบนี้
(จาก presentation เรื่อง Yoda in Haskell ของ Ben)
fix f = let x = f x in x

โชคดีที่เหลือบมองเห็น comment ที่ Ben เขาเขียนเหนือ function นี้ มันมีคำว่า Y combinator อยู่ด้วย

เรื่อง Y combinator เคยผ่านตามาหลายครั้งแล้ว แต่ไม่เคยทำความเข้าใจได้สักที
วันนี้เลยได้ฤกษ์การพยายามครั้งใหม่

จากการ search google ก็พบว่า code ข้างบนนั้น มันมีชื่อเรียกว่า
Fixed point combinator
หลักการมันประมาณนี้

เริ่มที่คำว่า Fixed point ก่อน
fix point ก็คือ ค่าที่ทำให้ผลลัพท์ของ function มีคุณสมบัติแบบนี้
f(x) = x

ในทางคณิตศาสตร์ สมมติเรามี function อยู่อันหนึ่งซึ่งมี definition ดังนี้
f(x) = x^2

ค่า fixed point คือ function นี้ก็คือ 0 และ 1
เพราะ 0^2 == 0 และ 1^2 = 1

ใน functional language ทุกอย่างเป็น function
ดังนั้น เมื่อมี function ก็แสดงว่า มันก็ต้องมี fixed point ได้เหมือนกัน
ลองนึกถึง higher-order function f ที่รับ parameter เป็น function
มันก็ควรจะมี fixed point function p ซึ่ง
f(p) = p


Y combinator ก็คือ function g ซึ่งรับ parameter เป็น function f
ผลลัพท์ที่ได้ ก็คือ function p ซึ่งเป็น fixed point ของ function f
p = g(f), f(p) = p

ลองอ่านคำอธิบาย contract ของ Y combinator เทียบกับ function ข้างบน
Give me myself and a higher order function f, and I’ll return to you a function that is a fixed point of f.


ถ้าลองแทน function ข้างบนไปมา ก็จะได้
f(g(f)) = g(f)

อ้าจ้องไปจ้องมา แล้วมันก็คือ let x = f x in x นั่นเอง

ประเด็นหลักๆของไอ้ Fix ก็คงจะอยู่ที่เรื่อง Lambda expression
เนื่องจากเราไม่สามารถเขียน recursive function ในรูป lambda expression ได้
ใครอยากรู้ลองอ่านไอ้นี่เอาแล้วกัน
http://en.wikipedia.org/wiki/Lambda_abstraction#Recursion

ลองดูตัวอย่าง่ factorial บ้าง
ปกติเราเขียน factorial อย่างนี้

fact n = if n == 0 then 1 else n * fact (n-1)


ลองปรับ form ให้เป็น lambda expression โดยสร้าง function genfact ขึ้นมา

genfact f n = if n == 0 then 1 else n * f(n-1)

ลอง apply fix เข้าไป

fix genfact 3 = fact (fix genfact) 3
= 3 * ((fix genfact) 2)
= 3 * (genfact (fix genfact) 2)
= 3 * 2 * ((fix genfact) 1)
= 3 * 2 * 1 * ((fix genfact) 0)
= 3 * 2 * 1 * 1
= 6


พอแล้ว stack ผม overflow แล้ว

Related link from Roti

Monday, July 23, 2007

Max sum ของ Sub-array

zdk post โจทย์ข้อนี้ ใน codenone
เพื่อเป็นการฝึกฝน functional language ผมจึงลองทำด้วย haskell ดู
ทำแล้ว หน้าตาออกมาดูไม่ได้ ก็เลยไป search หาดูว่า บรรดาผู้เชี่ยวชาญ haskell
เข้าทำไว้อย่างไรบ้าง ซึ่งก็สมหวัง เพราะมีการ post ไว้ใน mailing list นี้ Link

ปัญหานี้ ถ้าคิดแบบง่ายสุดก่อน(ไม่คำนึงเรื่อง performance) ก็คือ
1. หา sublist ทั้งหมด
2. คำนวณแปะค่า sum เข้าไปไว้ที่หน้าสุดของ sublist แต่ละตัว
3. หา maximum sum
4. return ค่าที่ได้ โดยโยนค่า sum ทิ้งไป

เริ่มด้วยการหา sublist
ความต้องการคือ
sublist [1,2,3] ต้องได้ [[1],[1,2],[1,2,3],[2],[2,3],[3]] (ไม่จำเป็นต้องเรียงลำดับ)
ดู code ที่ผมเขียน เสียก่อน
sublists xs = sublists' xs [] 
sublists' [] acc = acc
sublists' xs acc = sublists' (tail xs) (tmp ++ acc)
where tmp = snd $ mapAccumL (\acc x -> (x:acc, x:acc)) [] xs

น่าเกลียดมาก เมื่อนำไปเทียบกับมือเก๋าๆแล้ว

เริ่มจากบรรทัดนี้ก่อน เป้าหมายบรรทัดนี้คือ ถ้ามี input เป็น [1,2,3] ต้องได้ [[1],[1,2],[1,2,3]] ออกมา
where tmp = snd $ mapAccumL (\acc x -> (x:acc, x:acc)) [] xs

สามารถใช้ List comprehension แทนได้ดังนี้
where tmp = [ys | n <- [1..length xs], ys <- [(take n xs)]]

ยังยังไม่พอ มี guru มาเฉลยอีกว่า ยาวไป ใช้แค่นี้พอ
where tmp = inits xs

อาฮ้า มี function นี้ให้ใช้ด้วย ตั้งชื่อไม่สื่ออย่างนี้ จะหาเจอได้อย่างไร

ขั้นถัดไปคือปรับตรงบรรทัดนี้
sublists xs = sublists' xs []
sublists' [] acc = acc
sublists' xs acc = sublists' (tail xs) (tmp ++ acc)

เยิ่นเย้อสุดๆ เหลือแค่นี้ก็พอ
sublists [] = []
sublists xs = tmp ++ sublists (tail xs)

อืมม์ได้เท่านี้ก็หรูแล้ว เจอแบบนี้เข้าไปสั้นกว่า
(function tails โผล่ออกมาอีกแล้ว มันมี function แบบนี้ด้วยวุ้ย
tails [1,2,3] = [[1,2,3],[2,3],[3],[]]
)
sublists xs = [zs | ys <- inits xs, zs <- tails ys]

เจ๋งแล้ว แต่มีสั้นกว่านี้อีก
sublists = concatMap tails . inits

แต่การใช้ inits,tails ก็มีปัญหาตรงที่ว่ามันมี empty array เข้ามาปนด้วย
มีคนเสนอ function unfoldr (เอาอีกแล้ว มี function unfoldr ด้วยหรือนี่)
ซึ่งดูดีกว่า ตรงที่ไม่มีปัญหาเรื่อง empty array
แถมยังเป็นการฉลาดที่นำ higher order function ที่มีอยู่แล้วมา apply ใช้
sublists xs = unfoldr f xs
where f [] = Nothing
f xs = Just ([ys | n <- [1..length xs], ys <- [(take n xs)]], tail xs)

หลังจากได้ sublist แล้ว ก็มีถึงขั้นการแปะ sum ลงไปข้างหน้า
ทำง่ายๆโดย
annotate_sum = map (\xs -> (sum xs, xs)) 

จากนั้นก็จัดการหา maximum โดยใช้ function maximumBy
ซึ่งผมเขียนแบบนี้
findMax xs = maximumBy (\a b -> compare (fst a) (fst b)) xs

ก็มีคนมาแสดงให้ดูว่า ทำแบบนี้ได้นะ
findMax xs = maximumBy (\(s1,_) (s2,_) -> compare s1 s2) xs

แล้วก็มีคนมาบอกอีกว่า มันมี function comparing ให้ใช้นะ
(แต่ผมหา function นี้ไม่เจอ คาดว่าคงอยู่ใน version ใหม่กว่าที่มี)
findMax xs = maximumBy (comparing fst)

เมื่อนำมาประกอบกัน ก็ได้ดังนี้
*Main> (snd . findMax . annotate_sum . sublists) [-1,2,5,-1,3,-2,1]
[2,5,-1,3]

Related link from Roti

Wednesday, April 11, 2007

MandelBrot Set ด้วย Haskell

จากโจทย์ใน codenone ที่ Implement ด้วย Ruby ไปแล้ว
คราวนี้มาลอง implement ด้วย haskell บ้าง

เริ่มด้วย algorithm การคำนวณค่า
ถ้าเป็น ruby เขียนแบบนี้
def is_mandelbrot(x,y) 
x0 = x
y0 = y
x2 = x*x
y2 = y*y

iter = 0
maxiter = 30

while ( x2 + y2 < 4 && iter < maxiter )
y = 2*x*y + y0
x = x2 - y2 + x0
x2 = x*x
y2 = y*y
iter += 1
end

if iter == maxiter || iter == 0
0.0
else
iter.to_f * 100 / maxiter
end

end


ใน imperative language จะมีพวก while loop ให้ใช้
แต่ใน haskell ไม่มี loop แบบนี้
ดังนั้นเราต้องแปลงให้เป็น tail-recursive แทน

max_iter = 30
is_mandel x y = is_mandel' x y max_iter x y
is_mandel' x y cnt x0 y0
| cnt == 0 = 0.0
| exceed = (max_iter - cnt) / max_iter
| otherwise = is_mandel' (x2-y2+x0) (2*x*y+y0) (cnt-1) x0 y0
where x2 = x * x
y2 = y * y
exceed = x2 * y2 > 4


ขั้นถัดไปก็คือคำนวณว่าจะ render ภาพอย่างไร
โดยในโจทย์ เขาจะให้เรากำหนด coordinate ของมุมบนซ้าย กับมุมล่างขวา
จากนั้นก็ให้เราคำนวณรูป โดยกำหนดว่า resolution ของการ plot ต้องมีอย่างน้อย 200 pixel,
ถ้าเขียนด้วย python จะเขียนดังนี้ (code นี้คุณสุกรีเป็นคนเขียน)
def mandelbrot(ul,lr,callback,step=(200,200),maxiter=255,limit=2):
xs,ys = step
x0,y0 = ul.real,ul.imag
x1,y1 = lr.real,lr.imag
xd,yd = (x1-x0)/xs,(y1-y0)/ys
i = 0
y = y0
for i in range(ys):
x = x0
for j in range(xs):
color = mandelbrot_point(x,y,maxiter,limit)
callback(i,j,x,y,color)
y += yd

จะเห็นว่ามี for loop ซ้อนกัน 2 ชั้น
haskell ก็ไม่มี for loop ให้ใช้เหมือนเดิม
ดังนั้น เราจะเปลียนแนวคิดไปเป็น List แทน
เริ่มโดยหาจุดที่เป็นไปได้บน แกน X ก่อน
โดยต้องการ list หน้าตาแบบนี้
[(-2,0),(-1.98,1),(-1.96,2),....]
ตัวแรกใน tuple คือ ค่าที่จะนำไปคำนวณสมการ
ส่วนตัวที่สองใน tuple ก็คือค่าที่ใช้ plot จุดบนแกน x
loopX startX endX = take w $ iterate (\(x,x') -> (x + stepX, x' + 1)) (startX,0)
where stepX = (endX - startX) / width
w = floor width

take คือการดึงค่าออกจาก list ตามจำนวนที่ระบุ เช่น
take 3 [1,2,3,4,5] ก็จะได้ [1,2,3]
ส่วน iterate มันอธิบายยาก ลองดูตัวอย่าง
iterate (\x -> x + 1) 1 ได้ผลลัพท์คือ [1,2,3,4,... จน infinity]
iterate (\x -> x + 2) 1 ได้ผลลัพท์คือ [1,3,5,7,...]
ดังนั้น code ข้างบน ก็อ่านได้ว่า
"ดึง element ออกมาจาก list ตามจำนวน pixel ที่เราจะ plot"
ซึ่งก็คือ 200 element

จากนั้นก็หาจุดที่เป็นไปได้บน แกน Y
loopY startY endY = take h $ iterate (\(y,y') -> (y - stepY, y' + 1)) (startY,0)
where stepY = (startY - endY) / height
h = floor height


นำ list ของแกน X และ แกน Y
มาทำ cartesial product โดยใช้ List Comprehension
โดย sx คือ x ที่มุมบนซ้าย
ex คือ x ที่มุมล่างขวา
sy คือ y ที่มุมบนซ้าย
ey คือ y ที่มุมล่างขวา
mandelset sx sy ex ey = [(x',y',is_mandel x y) | (x,x') <- (loopX sx ex), (y,y') <- (loopY sy ey)]

ถึงขั้นนี้ เราก็ได้ผลลัพท์ออกมาเป็น list ของ tuple แบบนี้
[(x coordinate,y coordinate, ค่าที่ได้จากการคำนวณว่าอยู่ใน set ของ mandelbrot )]
ซึ่งสามารถนำไป plot ได้แล้ว

ขั้นตอนที่ยากอีกขั้นของ Haskell ก็คือ จะเลือกใช้ Graphic library อันไหนดี
เพราะมันมีให้เลือกเยอะ,
แต่ที่เหมือนกันหมดทุกเจ้าก็คือ
ถ้าอยากรู้ว่าทำงานอย่างไร ก็ให้อ่าน source code ของ example เอา

ผมตกลงเลือกใช้ Graphics.UI.GLUT
(หลังจากเลือกไปตัวหนึ่งแล้ว แต่มัน run ช้ามาก,
กับอีกตัวหนึ่งที่ install ไม่ผ่าน)

ปัญหาของโปรแกรมในส่วนของ UI ก็คือ State
เนื่องจาก Haskell มันเป็น pure functional
การจัดการกับ state ก็เลยต้องใช้ Monad เข้ามาช่วย
ลองดูการ define state
โดยผมจะเก็บค่า มุมบนซ้ายกับมุมล่างขวา
ซึ่งค่านี้จะเปลี่ยนไปเรื่อยๆ เมื่อ user กด zoom

data State = State { sx, sy, ex, ey :: IORef Float }

makeState :: IO State
makeState = do
sx <- newIORef (-2.0)
sy <- newIORef 2.0
ex <- newIORef 2.0
ey <- newIORef (-2.0)
return $ State { sx = sx, sy = sy, ex = ex, ey = ey }


เวลาจะ get ค่า ก็ทำแบบนี้
sx <- get (sx state)
ส่วนเวลาจะ set ค่า ก็ต้องทำแบบนี้
writeIORef (sx state) val

code ที่เหลือเป็น code ที่เกี่ยวกับ open-gl แล้ว
มีหน้าตาประมาณนี้ (ไม่ได้แสดงส่วนที่เกี่ยวกับการ zoom)
display :: State -> DisplayCallback
display state = do
clear [ ColorBuffer ]
sx <- get (sx state)
sy <- get (sy state)
ex <- get (ex state)
ey <- get (ey state)
renderPrimitive Points $ do
mapM_ plot $ mandelset sx sy ex ey
swapBuffers

reshape :: ReshapeCallback
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
ortho2D 0 (fromIntegral w) 0 (fromIntegral h)
scale 1 (-1) (1::GLfloat)
translate (Vector3 0 (-400) (0 :: GLfloat))


keyboardMouse :: State -> KeyboardMouseCallback
keyboardMouse state (MouseButton b) Down _ (Position x y) = case b of
LeftButton -> zoom state x y
_ -> return ()
keyboardMouse _ _ _ _ _ = return ()

main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ DoubleBuffered, RGBMode ]
initialWindowSize $= Size (floor width) (floor height)
createWindow progName
myInit
state <- makeState
displayCallback $= display state
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboardMouse state)
mainLoop

Related link from Roti

Wednesday, January 03, 2007

Ninety-nine Lisp Problem #P07

วันนี้นั่งทำโจทย์ข้อที่ 7, ในแง่ของ clisp กับ erlang
ข้อนี้ไม่ยากนัก แต่ในแง่ของ haskell แล้ว program ออกมาไม่สวยนัก
ก็เลย mail ไปถามใน mailing list ของ haskell ดู
ซึ่งก็ได้ผล มีคนเก่งๆมาช่วยไขความกระจ่าง
ถือเป็น mailing list ที่น่าประทับใจอันหนึ่ง

ลองดูโจทย์

P07 (**) Flatten a nested list structure.
Transform a list, possibly holding lists as elements into a `flat' list by replacing each list with its elements (recursively).

Example:
* (my-flatten '(a (b (c d) e)))
(A B C D E)

Hint: Use the predefined functions list and append.


CLisp
ใช้ append ในการ ต่อ list 2 อันเข้าด้วยกัน
(defun my-flatten (lst)
(cond ((not (listp lst)) (list lst))
((null lst) nil)
(t (append (my-flatten (car lst))
(my-flatten (cdr lst))))))


Erlang
erlang ก็ใช้วิธีตามแบบ lisp มาติดๆ
แต่ด้วยการใช้ guard + pattern matching เข้ามาช่วย
ทำให้ดูง่ายกว่า clisp
-module(p07).
-export([flat/1]).

flat([]) -> [];
flat(X) when atom(X) -> [X];
flat([H|T]) -> flat(H) ++ flat(T).


Haskell
ข้อนี้ haskell ไม่สามารถทำตรงๆได้
เนื่องจาก type system ของ Haskell
ไม่สามารถกำหนด type nested array แบบนี้ได้

[1,2] type คือ [a]
[1,[2,3]] type คือ [[a]]
[1,[2,[3,4],5]] type คือ [[[a]]]

จากโจทย์ จะเห็นว่า list มันจะซ้อนกันกี่ชั้นก็ได้
ทำให้ไม่สามารถ declare type ได้

ถ้าจะแก้โจทย์นี้ ก็ต้องเปลี่ยน structure ของ list ก่อน
โดย declare เป็น abstract data type ขึ้นมาก
จาก
[1,[2,[3,4],5]]
ให้เป็น
[E 1, S[E 2, S[E 3, E 4], E 5]]

ตัว data type เรา declare แบบนี้
data Store a = E a | S [Store a]
deriving (Show)


จากนั้นก็เขียน function
flat :: [Store a] -> [a]
flat [] = []
flat ((E x):xs) = [x] ++ flat xs
flat ((S x):xs) = flat x ++ flat xs


จะเห็นว่ามันยืดยาวไม่สวยงาม
ผมก็เลยเขียนไปถามใน mailing list
ลองอ่านที่เขาตอบมาดู
flatten a nested list
ผมชอบ solution ที่ Conor McBride ตอบมากสุด
ทำให้รู้ด้วยว่า list มันเป็น monadic structure ด้วย

flat1 :: Store a -> [a]
flat1 (E a) = return a
flat1 (S xs) = xs >>= flat1

magic อยู่ที่ function >>=
ซึ่งถ้าไปดูนิยามมันใน library ดู จะเห็นนิยามมันเป็นแบบนี้
instance Monad [ ] where
(x:xs) >>= f = f x ++ (xs >>= f)
[] >>= f = []
return x = [x]
fail s = []

Related link from Roti

Friday, December 29, 2006

Ninety-nine Lisp Problem #p04,#p05


P04 (*) Find the number of elements of a list.

ทำได้ 2 แบบคือ
1. ใช้ recursive ธรรมดา
2. ใช้ tail recursive

clisp
(defun len (lst)
(if (null lst)
0
(1+ (len (cdr lst)))))

(defun len-2 (lst &optional (cnt 0))
(if (null lst)
cnt
(len-2 (cdr lst) (1+ cnt))))


haskell
len :: [a] -> Int
len ([]) = 0
len (_:xs) = 1 + len xs


len_2 :: [a] -> Int
len_2 (xs) = len_helper xs 0
where
len_helper ([]) n = n
len_helper (_:xs) n = len_helper xs (n + 1)


erlang
-module(p04).
-export([len/1,len_2/1]).

len([]) ->
0;
len([_|XS]) ->
1 + len(XS).


len_2(L) ->
len_iter(L,0).

len_iter([],N) ->
N;
len_iter([_|XS],N) ->
len_iter(XS,N+1).


P05 (*) Reverse a list.


implement ทั้งหมดแบบ tail-recursive

clisp
(defun rev (lst &optional (tmp '()))
(if (null lst)
tmp
(rev (cdr lst) (cons (first lst) tmp))))


haskell
inv :: [a] -> [a]
inv l = invx l []
where
invx [] y = y
invx (x:xs) y = invx xs (x : y)

ดูยาว, แต่ถ้าไปดู implement ของ hugs เขาจะเขียนแค่นี้
reverse   :: [a] -> [a]
reverse = foldl (flip (:)) []


erlang
-module(p05).
-export([rev/1]).

rev(X) ->
rev(X,[]).

rev([], L) ->
L;
rev([H|T], L) ->
rev(T, [H|L]).

Related link from Roti