module TBit.Hamiltonian.Builder.Examples where

import Data.Graph.Inductive.Graph
import Numeric.LinearAlgebra.HMatrix
import TBit.Types
import Data.Monoid

ring :: Int -> CellGraph
ring n = hermitize $ mkGraph vs es
    where vs = [ (j, ScalarSite  j) | j <- [1..n] ]
          es = (n, 1, unit 1 - unit n) 
             : [ (j, j+1, unit (j+1) - unit j) | j <- [1..pred n]]
          m = fromIntegral n

          unit :: Int -> Vector Double
          unit j' = let j = fromIntegral j'
                     in vector [ cos $ 2*pi*j/m , sin $ 2*pi*j/m ]

squareLattice :: CellGraph
squareLattice = mkGraph vs es
    where vs = [ (1, ScalarSite  1) ]
          es = [ (1, 1, vector [0,1])
               , (1, 1, vector [1,0])
               , (1, 1, vector [0,-1])
               , (1, 1, vector [-1,0]) ]

hexLattice :: CellGraph
hexLattice = hermitize $ mkGraph vs es
    where vs = [ (1, ScalarSite  1)
               , (2, ScalarSite  2)]
          es = [ (1, 2, vector [cos $ 2*pi/3, sin $ 2*pi/3])
               , (1, 2, vector [cos $ 4*pi/3, sin $ 4*pi/3]) 
               , (1, 2, vector [1,0]) ]

kagomeLattice :: CellGraph
kagomeLattice = hermitize $ mkGraph vs (map (fmap (scale 0.5)) es)
    where vs = [ (1, VectorSite 1 delta1)
               , (2, VectorSite 2 delta2)
               , (3, VectorSite 3 delta3)]
          es = [ (1, 2, vector [1,0])
               , (1, 2, negate $ vector [1,0])
               , (2, 3, vector [cos $ 4*pi/3, sin $ 4*pi/3]) 
               , (2, 3, negate $ vector [cos $ 4*pi/3, sin $ 4*pi/3]) 
               , (3, 1, vector [cos $ 2*pi/3, sin $ 2*pi/3])
               , (3, 1, negate $ vector [cos $ 2*pi/3, sin $ 2*pi/3]) ]
          delta1 = vector [ cos $ pi/6, sin . negate $ pi/6 ]
          delta2 = vector [ cos $ 7*pi/6 , sin $ 7*pi/6 ]
          delta3 = vector [ 0 , 1 ]
               

instance Graph g => Monoid (g a b) where
    mempty = empty
    mappend g g' = mkGraph (labNodes g ++ labNodes g') 
                           (labEdges g ++ labEdges g')



kagomeRibbon :: Int -> CellGraph
kagomeRibbon = hermitize . kagomeRibbon'

kagomeRibbon' :: Int -> CellGraph
kagomeRibbon' 0 = hermitize $ mkGraph vs es
    where vs = [ (1, VectorSite 1 delta1)
               , (2, VectorSite 2 delta2) ]
          es = [ (1, 2, vector [0.5, 0]) ]
          delta1 = vector [ cos $ pi/6, sin . negate $ pi/6 ]
          delta2 = vector [ cos $ 7*pi/6 , sin $ 7*pi/6 ]
kagomeRibbon' n = (mkGraph vs es) `mappend` (boost $ kagomeRibbon (pred n))
    where vs = [ (1, VectorSite 1 delta1)
               , (2, VectorSite 2 delta2)
               , (3, VectorSite 3 delta3) ]
          es = [ (1, 2, e12)
               , (2, 3, e23)
               , (3, 1, e31)
               , (2, 1, e12)
               , (3, 4, negate e31)
               , (3, 5, e23)]
          e12 = vector [0.5, 0]
          e23 = vector [cos $ 4*pi/3, sin $ 4*pi/3]
          e31 = vector [cos $ 2*pi/3, sin $ 2*pi/3]
          delta1 = vector [ cos $ pi/6, sin . negate $ pi/6 ]
          delta2 = vector [ cos $ 7*pi/6 , sin $ 7*pi/6 ]
          delta3 = vector [ 0 , 1 ]
          boost g = let (e,v) = ( labEdges g , labNodes g )
                     in mkGraph ( map (\(nd, VectorSite _ dt) 
                                       -> (nd + 3, VectorSite (nd + 3) dt)) v )
                                ( map (\(src, tgt, dlt)
                                       -> (src + 3, tgt + 3, dlt)) e )



hermitize :: CellGraph -> CellGraph
hermitize g = insEdges (map (\(x,y,r) -> (y,x,negate r)) $ labEdges g) g