module SVG (
	textToSVG
) where

import Control.Applicative
import Data.Maybe
import Data.Char
import System.FilePath
import Text.XML.YJSVG hiding (Image)
import qualified Text.XML.YJSVG as SVG

import Text.Markdown.Pap
import SepWords
import Image

type FontsS = (String, String, String)
type Fonts = (Font, Font, Font)

-- headerFont, normalFont, codeFont :: Font
-- headerFont = Font "Kochi Gothic" Normal
-- normalFont = Font "Kochi Mincho" Normal
-- headerFont = Font "Sans" Normal
-- normalFont = Font "Serif" Normal
-- normalFont = "Kochi Gothic"
-- codeFont = "Kochi Gothic"
codeFont = Font "Monospace" Normal

textToSVG :: FontsS -> [(FilePath, String)] -> Bool -> Double -> [Text] -> [String]
textToSVG (hf, nf, cf) fp n r =
	map (showSVG (width r) (height r)) .
	textToSVGData (Font hf Normal, Font nf Normal, Font cf Normal) fp r (topMargin r) .
	preprocess .
	if n then addChapters [Nothing, Just 0, Just 0, Just 0, Nothing, Nothing] else id

width, height :: Double -> Double
width = (3535 *)
height = (5000 *)

topMargin, leftMargin, paraLeftMargin, codeLeftMargin, listLeftMargin
	:: Double -> Double
topMargin = (400 *)
leftMargin = (400 *)
paraLeftMargin = (+) <$> leftMargin <*> (200 *)
codeLeftMargin = (+) <$> paraLeftMargin <*> (200 *)
listLeftMargin = (+) <$> paraLeftMargin <*> (200 *)

bottomMargin :: Double -> Double
bottomMargin = (400 *)

bottomBorder :: Double -> Double
bottomBorder = (-) <$> height <*> bottomMargin

header :: Int -> Double -> Double
header i = ((1 / fromIntegral (i + 1)) * 450 *)
headerSep i = (* (4 / 3)) <$> header i

normal, normalSep :: Double -> Double
normal = (80 *)
normalSep = (* (4 / 3)) <$> normal

code, codeSep :: Double -> Double
code = (65 *)
codeSep = (* (4 / 3)) <$> code

lineChars :: Int
lineChars = 60

textToSVGData :: Fonts -> [(FilePath, String)] -> Double -> Double -> [Text] -> [[SVG]]
textToSVGData fs@(hf, nf, cf) fp r h [] = [[]]
textToSVGData fs@(hf, nf, cf) fp r h (Header n s : ts@(List l : _))
	| h' > bottomBorder r = [] : (ln : one') : rest'
	where
	(_, h', _) = listToSVGData nf 1 "*+-------" r (h + headerSep n r * 5 / 4 + 100 * r) (listLeftMargin r) l
	ln = Text (TopLeft (leftMargin r) (topMargin r + headerSep n r)) (header n r) (ColorName "black") hf s
	one' : rest' = textToSVGData fs fp r (topMargin r + headerSep n r * 5 / 4) ts
textToSVGData fs@(hf, nf, cf) fp r h (Header n s : ts@(Paras (p : _) : _))
	| h' > bottomBorder r = [] : (l : one') : rest'
	where
	(h', svgs) = paraToSVGData nf r (h + headerSep n r * 5 / 4) p
	l = Text (TopLeft (leftMargin r) (topMargin r + headerSep n r)) (header n r) (ColorName "black") hf s
	one' : rest' = textToSVGData fs fp r (topMargin r + headerSep n r * 5 / 4) ts
textToSVGData fs@(hf, nf, cf) fp r h (Header n s : ts@(i@(Image _ _ _) : _))
	| h + headerSep n r * 5 / 4 + getImageHeight fp r i > bottomBorder r =
		[] : (l : one') : rest'
	where
	l = Text (TopLeft (leftMargin r) (topMargin r + headerSep n r)) (header n r) (ColorName "black") hf s
	one' : rest' = textToSVGData fs fp r (topMargin r + headerSep n r * 5 / 4) ts
textToSVGData fs@(hf, nf, cf) fp r h (Header n s : ts)
	| h > bottomBorder r - headerSep n r = [] : (l' : one') : rest'
	| otherwise = (l : one) : rest
	where
	l = Text (TopLeft (leftMargin r) (h + headerSep n r)) (header n r) (ColorName "black") hf s
	l' = Text (TopLeft (leftMargin r) (topMargin r + headerSep n r)) (header n r) (ColorName "black") hf s
	one : rest = textToSVGData fs fp r (h + headerSep n r * 5 / 4) ts
	one' : rest' = textToSVGData fs fp r (topMargin r + headerSep n r * 5 / 4) ts
textToSVGData fs@(hf, nf, cf) fp r h (Paras [] : ts) = textToSVGData fs fp r h ts
textToSVGData fs@(hf, nf, cf) fp r h (Paras (p : ps) : ts)
	| h' > bottomBorder r = [] : (svgs' ++ one') : rest'
	| otherwise = (svgs ++ one) : rest
	where
	(h', svgs) = paraToSVGData nf r h p
	(h'', svgs') = paraToSVGData nf r (topMargin r) p
	one : rest = textToSVGData fs fp r h' (Paras ps : ts)
	one' : rest' = textToSVGData fs fp r h'' (Paras ps : ts)
textToSVGData fs@(hf, nf, cf) fp r h (List l : ts)
	| h' > bottomBorder r = [] : (svgs' ++ one') : rest'
	| otherwise = (svgs ++ one) : rest
	where
	(_, h', svgs) = listToSVGData nf 1 "*+-------" r (h + 100 * r) (listLeftMargin r) l
	(_, h'', svgs') = listToSVGData nf 1 "*+-------" r (topMargin r) (listLeftMargin r) l
	one : rest = textToSVGData fs fp r (h' + 100 * r) ts
	one' : rest' = textToSVGData fs fp r (h'' + 100 * r) ts
textToSVGData fs@(hf, nf, cf) fp r h (Code s : ts)
	| h' > bottomBorder r = [] : (svgs' ++ one') : rest'
	| otherwise = (svgs ++ one) : rest
	where
	(h', svgs) = codeToSVGData cf r (h + codeSep r) (lines s)
	(h'', svgs') = codeToSVGData cf r (topMargin r) (lines s)
	one : rest = textToSVGData fs fp r (h' + codeSep r) ts
	one' : rest' = textToSVGData fs fp r (h'' + codeSep r) ts
textToSVGData fs@(hf, nf, cf) fp r h (Image _ p ttl : ts)
	| h + ht > bottomBorder r =
		[] : (SVG.Image (TopLeft left (topMargin r)) wt ht p : svg') : svgs'
	| otherwise = (SVG.Image (TopLeft left h) wt ht p : svg) : svgs
	where
	svg : svgs = textToSVGData fs fp r (h + ht + r * 100) ts
	svg' : svgs' = textToSVGData fs fp r (topMargin r + ht + r * 100) ts
	size = case ttl of
		"small" -> Small
		"large" -> Large
		_ -> Medium
	(wt, ht) = case getSize fp p size of
		Just (w_, h_) -> (w_ * ratio, h_ * ratio)
		_ -> (r * 1000, r * 1000)
	ratio = width r - 2 * leftMargin r
	left = case ttl of
		"large" -> leftMargin r
		"small" -> ratio * 4 / 10
		_ -> ratio * 1 / 3
textToSVGData fs@(hf, nf, cf) fp r h (Link txt addrs ttl : ts)
	| h + normalSep r > bottomBorder r = [] : (l : svg') : svgs'
	| otherwise = (l : svg) : svgs
	where
	svg : svgs = textToSVGData fs fp r (h + normalSep r) ts
	svg' : svgs' = textToSVGData fs fp r (topMargin r) ts
	l = Text (TopLeft (paraLeftMargin r) (h + normalSep r)) (normal r) (ColorName "blue")
			nf $ txt ++ "(" ++ addrs ++ ")"

splitAtString :: Int -> String -> (String, String)
splitAtString len = sepStr 0
	where
	sepStr _ "" = ("", "")
	sepStr n (c : c'@('ー') : cs)
		|  n > len = ([c, c'], cs)
		| otherwise = let (s, t) = sepStr (n + 4) cs in (c : c' : s, t)
	sepStr n (c : c'@('。') : cs)
		|  n > len = ([c, c'], cs)
		| otherwise = let (s, t) = sepStr (n + 4) cs in (c : c' : s, t)
	sepStr n (c : cs)
		| n > len = ([c], cs)
		| isAscii c = let (s, t) = sepStr (n + 1) cs in (c : s, t)
		| otherwise = let (s, t) = sepStr (n + 2) cs in (c : s, t)

separateString :: Int -> String -> [String]
separateString len = sepStr 0
	where
	sepStr _ "" = [[]]
	sepStr n (c : c'@('ー') : cs)
		|  n > len = [c, c'] : sepStr 0 cs
		| otherwise = let s : ss = sepStr (n + 4) cs in (c : c' : s) : ss
	sepStr n (c : c'@('。') : cs)
		|  n > len = [c, c'] : sepStr 0 cs
		| otherwise = let s : ss = sepStr (n + 4) cs in (c : c' : s) : ss
	sepStr n (c : cs)
		| n > len = [c] : sepStr 0 cs
		| isAscii c = let s : ss = sepStr (n + 1) cs in (c : s) : ss
		| otherwise = let s : ss = sepStr (n + 2) cs in (c : s) : ss

paraToSVGData :: Font -> Double -> Double -> String -> (Double, [SVG])
paraToSVGData nf r h str = (h', l : svgs)
	where
	(s, t) = splitWords (lineChars - 3) str
	l = Text (TopLeft (paraLeftMargin r + normal r) (h + normal r)) (normal r) (ColorName "black") nf s
	ls = sepWords lineChars t
	(h', svgs) = strsToSVGData nf r (h + normalSep r) ls

strsToSVGData :: Font -> Double -> Double -> [String] -> (Double, [SVG])
strsToSVGData _ r h [] = (h, [])
strsToSVGData nf r h ([] : ss) = strsToSVGData nf r h ss
strsToSVGData nf r h (s : ss) = (h', l : svgs)
	where
	l = Text (TopLeft (paraLeftMargin r) (h + normal r)) (normal r) (ColorName "black") nf s
	(h', svgs) = strsToSVGData nf r (h + normalSep r) ss

listToSVGData :: Font -> Int -> String -> Double -> Double -> Double -> List -> (Int, Double, [SVG])
listToSVGData _ n sym r y x [] = (n, y, [])
listToSVGData nf n sym r y x (lst : lsts) = (n'', y'', svgs ++ svgs')
	where
	(n', y', svgs) = list1ToSVGData nf n sym r y x lst
	(n'', y'', svgs') = listToSVGData nf n' sym r y' x lsts

list1ToSVGData :: Font -> Int -> String -> Double -> Double -> Double -> List1 -> (Int, Double, [SVG])
list1ToSVGData nf n sym r y x (BulItem s lst) = (n, h', l : svgs)
	where
	l = Text (TopLeft x (y + normal r)) (normal r) (ColorName "black") nf $ head sym : ' ' : s
	(_, h', svgs) = listToSVGData nf n (tail sym) r (y + normalSep r) (x + normal r * 2) lst
list1ToSVGData nf n sym r y x (OrdItem s lst) = (n + 1, h', l : svgs)
	where
	l = Text (TopLeft x (y + normal r)) (normal r) (ColorName "black") nf $ show n ++ '.' : ' ' : s
	(_, h', svgs) = listToSVGData nf n (tail sym) r (y + normalSep r) (x + normal r * 2) lst

codeToSVGData :: Font -> Double -> Double -> [String] -> (Double, [SVG])
codeToSVGData _ _ h [] = (h, [])
codeToSVGData cf r h (s : ss) = (h', l : svgs)
	where
	l = Text
		(TopLeft
			(codeLeftMargin r + (code r) * spaces)
			(h + code r))
		(code r) (ColorName "black") cf s
	(h', svgs) = codeToSVGData cf r (h + codeSep r) ss
	spaces = (* (123 / 200)) $ fromIntegral $ length $ takeWhile (== ' ') s

addChapters :: [Maybe Int] -> [Text] -> [Text]
addChapters _ [] = []
addChapters cs (Header n s : ts)
	| isJust $ cs !! (n - 1) =
		Header n (chaps ++ " " ++ s) : addChapters newCs ts
	| otherwise = Header n s : addChapters newCs ts
	where
	chaps = concatMap (++ ".") $ map show $ catMaybes $ take n newCs
	newCs = take (n - 1) cs ++ [(+ 1) <$> cs !! (n - 1)] ++ map reset (drop n cs)
	reset (Just _) = Just 0
	reset _ = Nothing
addChapters cs (t : ts) = t : addChapters cs ts

preprocess :: [Text] -> [Text]
preprocess [] = []
preprocess (Paras strs : ts) = Paras (map remSpaces strs) : preprocess ts
preprocess (t : ts) = t : preprocess ts

remSpaces :: String -> String
remSpaces "" = ""
remSpaces (c : ' ' : c' : cs)
	| not (isAscii c) || not (isAscii c') = c : c' : remSpaces cs
remSpaces (c : cs) = c : remSpaces cs

getSize :: [(FilePath, String)] -> FilePath -> Size -> Maybe (Double, Double)
getSize dict fp sz = case lookup fp dict of
	Just src -> convertedSize src sz
	_ -> error $ show (map fst dict) ++ " " ++ show fp -- Nothing

getImageHeight :: [(FilePath, String)] -> Double -> Text -> Double
getImageHeight fp r (Image _ p ttl) = ht
	where
	ratio = width r - 2 * leftMargin r
	size = case ttl of
		"small" -> Small
		"large" -> Large
		_ -> Medium
	(wt, ht) = case getSize fp p size of
		Just (w_, h_) -> (w_ * ratio, h_ * ratio)
		_ -> (r * 1000, r * 1000)
getImageHeight _ _ _ = error "not Image"