{-# Language FlexibleInstances #-}
module Blocks where
import SimpleProp
import Data.List ((\\))
-- These for pretty printing
import qualified Text.PrettyPrint.HughesPJ as PP
import Text.PrettyPrint.HughesPJ(Doc,text,int,(<strong>),(<+>),($+$),render)
-------------------------------------------------------
-- A Block is just a [String] with extra information
data Block = Block Int Int [String]
dim (Block w h xs) = (w,h)
--------------------------------------------------------
class Blockable t where
 toBlock :: t -> Block
instance Blockable String where
 toBlock = oneBlock
to x = toBlock(show x)
--------------------------------------------------------
-- useful helper functions
pad :: Int -> [String] -> [String]
pad n xs = xs ++ replicate n ""
fit :: Int -> String -> String
fit n xs &#124; n==m = xs
 &#124; n<m = take n xs &#124; n>m = xs ++ replicate (n-m) ' '
 where m = length xs
maxx [] = 0
maxx xs = maximum xs
justifyH n xs = map (fit n) xs
justifyV n xs &#124; n==height = ys
 &#124; n < height = take n ys &#124; n> height = replicate (n-height) blanks ++ ys -- bottom aligned
 &#124; n> height = ys ++ replicate (n-height) blanks -- top aligned
 where width = maxx(map length xs)
 height = length xs
 blanks = replicate width ' '
 ys = justifyH width xs
----------------------------------------------------
-- operations to create Blocks from primitive data
center (b@(Block w l s)) size &#124; w>= size = b
center (b@(Block w l s)) size = lineUp[left,b,right]
 where delta = size - w
 leftsize = delta `div` 2
 rightsize = delta - leftsize
 left = oneBlock(fit leftsize "")
 right = oneBlock(fit rightsize "")
oneBlock :: String -> Block
oneBlock s = Block width (length zs) (map (fit width) zs)
 where width = maxx (map length zs)
 zs = lines s
block :: Int -> String -> Block
block n s = Block width (length zs) (map (fit (max width n)) zs)
 where width = maximum (map (\ s -> max n (length s)) zs)
 zs = lines s
manyBlock:: [String] -> Block
manyBlock xs = Block width height (justifyH width xs)
 where width = maxx(map length xs)
 height = length xs
docBlock:: Doc -> Block
docBlock doc = manyBlock xs
 where xs = lines(render doc)
------------------------------------------------------
-- Block to Block functions
padBlock:: Block -> Int -> Block
padBlock (Block w h xs) n
 &#124; n==w = (Block w h xs)
 &#124; n> w = Block n h (justifyH n xs)
 &#124; n < w = Block n h (map (take n) xs) indentBlock:: Int -> Block -> Block
indentBlock n (Block w h xs) = Block (n+w) h (map add xs)
 where add xs = replicate n ' ' ++ xs
beside:: Block -> Block -> Block
beside (Block w1 h1 xs) (Block w2 h2 ys) = Block (w1+w2) height zs
 where height = max h1 h2
 xs1 = justifyV height xs
 ys1 = justifyV height ys
 zs = zipWith (++) xs1 ys1
above:: Block -> Block -> Block
above (Block w1 h1 xs) (Block w2 h2 ys) = Block width (h1+h2) (xs1++ ys1)
 where width = max w1 w2
 xs1 = justifyH width xs
 ys1 = justifyH width ys
box:: Int -> Block -> Block
box margin (Block w h xs) = Block width height zs
 where width = 1 + margin + w + margin + 1
 height = 1 + margin + h + margin + 1
 spaces = replicate margin ' '
 fill x = "&#124;" ++ spaces ++ x ++ spaces ++ "&#124;"
 edge = ["+" ++ replicate (w+2*margin) '-' ++ "+"]
 more = replicate margin (fill (replicate w ' '))
 zs = edge ++ more ++ (map fill xs) ++ more ++ edge
 
cap margin (Block w h xs) = Block width height zs
 where width = 1 + margin + w + margin + 1
 height = 1 + margin + h + margin + 1
 spaces = replicate margin ' '
 fill x = "&#124;" ++ spaces ++ x ++ spaces ++ "&#124;"
 edge = ["." ++ replicate (w+2*margin) '-' ++ "."]
 more = replicate margin (fill (replicate w ' '))
 zs = edge ++ more ++ (map fill xs) 
 
----------------------------------------------------
-- iterating over lists of Blocks
lineUp :: [Block] -> Block
lineUp [] = Block 0 0 []
lineUp (t:ts) = beside t (lineUp ts)
stack [] = Block 0 0 []
stack (t:ts) = above t (stack ts)
--sep [] = Block 0 0 []
--sep [x] = x
--sep (x:xs) = beside x (beside (oneBlock " ") (sep xs))
----------------------------------------------
-- some simple tests
pr (Block w h xs) = putStrLn (concat xs)
b1 = manyBlock ["tim","has many","cats."]
b2 = manyBlock ["Robert has many dogs","But he wilts"]
instance Show Block where
 show (Block w h xs) = (unlines xs)++("\nwidth = "++show w++", height = "++show h++".")
---------------------------------------------------
-- useful helper functions
schema (hyp@(Block w1 h1 xs)) 
 (concl@(Block w2 h2 ys)) 
 name = stack [hyp,line,concl]
 where line = Block (n+length name) 1 ([replicate n '-'++name])
 n = max w1 w2 
sep n xs = lineUp(punc xs) where
 punc [] = []
 punc [x] = [x]
 punc (x:xs) = x: oneBlock (replicate n ' '):(punc xs)
sequentBlock [] x name = x -- lineUp [oneBlock "[",x,oneBlock "]"]
sequentBlock xs x name = schema hyps (center x width) name
 where hyps = (sep 3 xs)
 (width,l) = dim hyps
plistf :: (a -> String) -> String -> [a] -> String -> String -> String
plistf f open xs sep close = open ++ help xs ++ close
 where help [] = ""
 help [x] = f x
 help (x:xs) = f x ++ sep ++ help xs 
 
plist :: Show a => String -> [a] -> String -> String -> String
plist = plistf show
</div><div class="naked_ctrl">
<form action="/index.cgi/contrast" method="get" name="gate">
<p><a href="http://altstyle.alfasado.net">AltStyle</a> によって変換されたページ <a href="http://web.cecs.pdx.edu/~sheard/course/LogicAndProgLang/hw/NaturalDeduction/Blocks.hs">(-&gt;オリジナル)</a>
/ <label>アドレス: <input type="text" name="naked_post_url" value="http://web.cecs.pdx.edu/~sheard/course/LogicAndProgLang/hw/NaturalDeduction/Blocks.hs" size="22" /></label> <label>モード: <select name="naked_post_mode">
<option value="default">デフォルト</option>
<option value="speech">音声ブラウザ</option>
<option value="ruby">ルビ付き</option>
<option value="contrast" selected="selected">配色反転</option>
<option value="larger-text">文字拡大</option>
<option value="mobile">モバイル</option>
</select>
<input type="submit" value="表示" />
</p>
</form>
</div>