{-# LANGUAGE TypeFamilies               #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Basic.Text.LRText
-- Copyright   :  (c) Stephen Tetley 2010
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Left-to-right measured text. The text uses glyph metrics so it 
-- can be positioned accurately.
-- 
--------------------------------------------------------------------------------

module Wumpus.Basic.Text.LRText
  ( 

   
    singleLineBL
  , singleLineCC

  , multiAlignLeft
  , multiAlignCenter
  , multiAlignRight


  ) where


import Wumpus.Basic.Graphic

import Wumpus.Core                              -- package: wumpus-core
import Wumpus.Core.Text.GlyphIndices

import Data.AffineSpace                         -- package: vector-space
import Data.VectorSpace

import Data.Char
import Data.Foldable ( foldrM )
import qualified Data.Map               as Map
import Data.Maybe 


-- One line of multiline text
--
data InterimText1 u = InterimText1
      { text1_escaped   :: EscapedText
      , text1_advance   :: (AdvanceVec u)
      } 
  deriving (Eq,Show)


singleLineBL :: (Ord u, FromPtSize u) 
             => String -> BoundedLocGraphic u
singleLineBL ss = interimText1 ss >>= singleLRText id 

singleLineCC :: (Fractional u, Ord u, FromPtSize u) 
             => String -> BoundedLocGraphic u
singleLineCC ss = glyphCapHeight  >>= \cap_h   -> 
                  interimText1 ss >>= \interim -> 
                  let hw = 0.5 * advanceH (text1_advance interim)
                  in singleLRText (.-^ vec hw (0.5 * cap_h)) interim

-- | Draw multi-line text, aligned to the left. 
--
-- The input string is split on newline with the Prelude function 
-- @lines@. The supplied point is the center of the text.
--
multiAlignLeft      :: (Fractional u, Ord u, FromPtSize u) 
                    => String -> BoundedLocGraphic u
multiAlignLeft      = 
    multiAligned drawLeftAligned1 (\wv pt -> pt .-^ hvec (0.5 * advanceH wv))


-- | Draw multi-line text, aligned on the horizontal center. 
--
-- The input string is split on newline with the Prelude function 
-- @lines@. The supplied point is the center of the text.
--
multiAlignCenter    :: (Fractional u, Ord u, FromPtSize u) 
                    => String -> BoundedLocGraphic u
multiAlignCenter    = 
    multiAligned drawCenterAligned1 (\_ pt -> pt)

-- | Draw multi-line text, aligned to the right. 
--
-- The input string is split on newline with the Prelude function 
-- @lines@. The supplied point is the center of the text.
--
multiAlignRight     :: (Fractional u, Ord u, FromPtSize u) 
                    => String -> BoundedLocGraphic u
multiAlignRight     = 
    multiAligned drawRightAligned1 (\wv pt -> pt .+^ hvec (0.5 * advanceH wv))


-- Build multi-line aligned text. 
--
-- The drawF functions regard the supplied point differently, for
-- instance @drawRightAligned1@ regards the point as 
-- baseline-right.
--
-- The dispF are applied to a point which is initially in the 
-- center of the drawing - for right aligned text it is displaced 
-- to the right (half the max width vectoer), for left aligned 
-- text it is displaced to the left. Center aligned text is not 
-- displaced.
--
multiAligned :: (Fractional u, Ord u, FromPtSize u) 
             => (InterimText1 u -> Point2 u -> BoundedGraphic u)
             -> (AdvanceVec u -> Point2 u -> Point2 u)
             -> String -> BoundedLocGraphic u
multiAligned drawF dispF ss = 
    linesToInterims ss >>= \(wv,xs)   ->
    glyphCapHeight     >>= \cap_h     -> 
    baselineSpacing    >>= \base_span ->   
    promote1 $ \p0 -> let p1  = dispF wv p0
                          axs = annotateStartPoints cap_h base_span p1 xs
                      in mergeLines drawF p1 axs

-- This needs sorting out so as not to throw an error
--
mergeLines :: (Num u, Ord u)
           => (InterimText1 u -> Point2 u -> BoundedGraphic u)
           -> Point2 u
           -> [(InterimText1 u, Point2 u)] -> BoundedGraphic u 
mergeLines fn fallback_pt = step
  where
    step [(x,pt)]    = fn x pt
    step ((x,pt):ys) = fn x pt `oplus` step ys  
    step _           = fn empty_fallback fallback_pt 

    empty_fallback   = InterimText1 (escapeString "") (hvec 0)




singleLRText :: (Ord u, FromPtSize u) 
             => (Point2 u -> Point2 u) -> InterimText1 u 
             -> BoundedLocGraphic u
singleLRText dispF (InterimText1 esc av) =
    glyphHeightRange >>= \(ymin, ymax)  ->
    promote1 $ \p0 -> let pt  = dispF p0
                          w   = advanceH av
                          ll  = pt .+^ vvec ymin
                          ur  = pt .+^ vec w ymax
                          bb  = boundingBox ll ur 
                      in (escapedline esc `at` pt) >>= \prim ->
                         return (bb, prim)



-- Point is baseline-left
--
drawLeftAligned1 :: (Ord u, FromPtSize u) 
                 => InterimText1 u -> Point2 u -> BoundedGraphic u
drawLeftAligned1 itext pt = singleLRText id itext `at` pt

-- Point is baseline-center
--
drawCenterAligned1 :: (Fractional u, Ord u, FromPtSize u)
                   => InterimText1 u -> Point2 u -> BoundedGraphic u
drawCenterAligned1 itext pt = 
    let hw = 0.5 * advanceH (text1_advance itext)    
    in singleLRText (.-^ hvec hw) itext `at` pt 

-- Point is baseline-right
--
drawRightAligned1 :: (Fractional u, Ord u, FromPtSize u)
                  => InterimText1 u -> Point2 u -> BoundedGraphic u
drawRightAligned1 itext pt = 
    let w = advanceH (text1_advance itext)
    in singleLRText (.-^ hvec w) itext `at` pt




-- This isn't worth the complexity  to get to one traversal...

linesToInterims :: (FromPtSize u, Ord u) 
                => String -> DrawingInfo (AdvanceVec u, [InterimText1 u])
linesToInterims = fmap post . mapM interimText1 . lines
  where
    post xs   = let vmax = foldr fn (hvec 0) xs in (vmax,xs)
    fn a vmax = avMaxWidth (text1_advance a) vmax

avMaxWidth :: Ord u => AdvanceVec u -> AdvanceVec u -> AdvanceVec u
avMaxWidth a@(V2 w1 _) b@(V2 w2 _) = if w2 > w1 then b else a

interimText1 :: FromPtSize u => String -> DrawingInfo (InterimText1 u)
interimText1 ss = let esc = escapeString ss in 
    postpro (mk esc) $ textVector esc
  where
    mk a b = InterimText1 { text1_escaped = a
                          , text1_advance = b }


textVector :: FromPtSize u => EscapedText -> DrawingInfo (AdvanceVec u)
textVector esc = let cs = getEscapedText esc in 
   foldrM (\c v -> charVector c >>= \cv -> return  (v ^+^ cv)) (vec 0 0) cs


charVector :: FromPtSize u => EscapedChar -> DrawingInfo (AdvanceVec u)
charVector (CharLiteral c) = unCF1 (ord c) avLookupTable
charVector (CharEscInt i)  = unCF1 i       avLookupTable
charVector (CharEscName s) = unCF1 ix      avLookupTable
  where
    ix = fromMaybe (-1) $ Map.lookup s ps_glyph_indices



-- baseline_span is the vertical distance from one baseline to
-- the next it is not /gap_height/.
--

annotateStartPoints :: Fractional u 
                 => u -> u -> Point2 u -> [InterimText1 u] 
                 -> [(InterimText1 u, Point2 u)]
annotateStartPoints _          _             _        []     = []
annotateStartPoints cap_height baseline_span (P2 x y) (z:rest) = 
    let y0 = if odd list_len then odd_start_y else even_start_y
        p0 = P2 x y0
    in (z,p0) : step (moveDown1 p0) rest
  where
    list_len        = 1 + length rest
    halfn           = fromIntegral $ list_len `div` 2
    center_to_bl    = 0.5 * cap_height
    half_gap_height = 0.5 * (baseline_span - cap_height)
    odd_start_y     = y - center_to_bl + halfn * baseline_span
    even_start_y    = y - half_gap_height - cap_height + halfn * baseline_span

    moveDown1       = \pt -> pt .-^ vvec baseline_span

    step _  []      = []
    step pt (a:as)  = (a,pt) : step (moveDown1 pt) as