contrib/haskell/src/Hkl/Lattice.hs

   1 {-# OPTIONS_GHC -Werror #-}
   2
   3 module Hkl.Lattice
   4        ( tau
   5        , Lattice (..)
   6        , busing
   7        ) where
   8 {-
   9     Copyright  : Copyright (C) 2014-2016 Synchrotron Soleil
  10     License    : GPL3+
  11
  12     Maintainer : picca@synchrotron-soleil.fr
  13     Stability  : Experimental
  14     Portability: GHC only?
  15 -}
  16
  17 import Prelude hiding (sqrt, sin, cos, (+), (-), (*), (**), (/))
  18 import qualified Prelude
  19
  20 import Numeric.LinearAlgebra (fromLists, Matrix)
  21
  22 import Numeric.Units.Dimensional.Prelude (_1, _2, meter, degree,
  23                                           (*~), (/~), (+), (-), (*), (**), (/),
  24                                           Length, Angle, sin, cos, one, sqrt,
  25                                           Dimensionless)
  26
  27
  28 tau :: Dimensionless Double
  29 tau = _1 -- 1 or 2*pi
  30
  31 data Lattice = Cubic (Length Double) -- a = b = c, alpha = beta = gamma = 90
  32              | Tetragonal (Length Double) (Length Double) -- a = b != c, alpha = beta = gamma = 90
  33              | Orthorhombic (Length Double) (Length Double) (Length Double) -- a != b != c,  alpha = beta = gamma = 90
  34              | Rhombohedral (Length Double) (Angle Double) -- a = b = c, alpha = beta = gamma != 90
  35              | Hexagonal (Length Double) (Length Double) -- a = b != c, alpha = beta = 90, gamma = 120
  36              | Monoclinic (Length Double) (Length Double) (Length Double) (Angle Double) -- a != b != c, alpha = gamma = 90, beta != 90
  37              | Triclinic (Length Double) (Length Double) (Length Double) (Angle Double) (Angle Double) (Angle Double) -- a != b != c, alpha != beta != gamma != 90
  38                deriving (Show)
  39
  40 busing' :: Length Double -> Length Double -> Length Double -> Angle Double -> Angle Double-> Angle Double -> Matrix Double
  41 busing' a b c alpha beta gamma = fromLists [[b00 /~ (one / meter), b01/~ (one / meter), b02/~ (one / meter)],
  42                                             [0  , b11 /~ (one / meter), b12 /~ (one / meter)],
  43                                             [0  , 0  , b22 /~ (one / meter)]]
  44     where
  45       b00 = tau * sin alpha / (a * d)
  46       b01 = b11 / d * (cos alpha * cos beta - cos gamma)
  47       b02 = tmp / d * (cos gamma * cos alpha - cos beta)
  48       b11 = tau / (b * sin alpha)
  49       b12 = tmp / (sin beta * sin gamma) * (cos beta * cos gamma - cos alpha)
  50       b22 = tau / c
  51       d = sqrt(_1 - cos alpha ** _2 - cos beta ** _2 - cos gamma ** _2 + _2 * cos alpha * cos beta * cos gamma)
  52       tmp = b22 / sin alpha;
  53
  54 busing :: Lattice -> Matrix Double
  55 busing (Cubic a) = busing' a a a (90 *~ degree) (90 *~ degree) (90 *~ degree)
  56 busing (Tetragonal a c) = busing' a a c (90 *~ degree) (90 *~ degree) (90 *~ degree)
  57 busing (Orthorhombic a b c) = busing' a b c (90 *~ degree) (90 *~ degree) (90 *~ degree)
  58 busing (Rhombohedral a alpha)= busing' a a a alpha alpha alpha
  59 busing (Hexagonal a c) = busing' a a c (90 *~ degree) (90 *~ degree) (120 *~ degree)
  60 busing (Monoclinic a b c beta) = busing' a b c (90 *~ degree) beta (90 *~ degree)
  61 busing (Triclinic a b c alpha beta gamma) = busing' a b c alpha beta gamma