Format.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Numeric.LinearProgramming.Format (
   Identifier,
   mathProg,
   ) where

import qualified Numeric.LinearProgramming.Common as LP
import Numeric.LinearProgramming.Common
         (Bound(..), Inequality(Inequality),
          Bounds, Direction(..), Objective, (.*))

import qualified Data.Array.Comfort.Storable as Array
import qualified Data.Array.Comfort.Shape as Shape
import qualified Data.List as List

import Text.Printf (printf)

import Prelude hiding (sum)



type Term = LP.Term Double

type Constraints ix = LP.Constraints Double ix


class Identifier ix where
   identifier :: ix -> String

instance Identifier Char where
   identifier x = [x]

instance Identifier c => Identifier [c] where
   identifier = concatMap identifier

instance Identifier Int where
   identifier = printf "x%d"

instance Identifier Integer where
   identifier = printf "x%d"


bound :: (Identifier ix) => Inequality ix -> String
bound (Inequality ix bnd) =
   printf "var %s%s;" (identifier ix) $
   case bnd of
      LessEqual up -> printf ", <=%f" up
      GreaterEqual lo -> printf ", >=%f" lo
      Between lo up -> printf ", >=%f, <=%f" lo up
      Equal x -> printf ", =%f" x
      Free -> ""


sum :: (Identifier ix) => [Term ix] -> String
sum [] = "0"
sum xs =
   let formatTerm (LP.Term c ix) = printf "%f*%s" c (identifier ix) in
   List.intercalate "+" $ map formatTerm xs

constraint :: (Identifier ix) => Inequality [Term ix] -> String
constraint (Inequality terms bnd) =
   let sumStr = sum terms in
   case bnd of
      LessEqual up -> printf "%s <= %f" sumStr up
      GreaterEqual lo -> printf "%f <= %s" lo sumStr
      Between lo up -> printf "%f <= %s <= %f" lo sumStr up
      Equal x -> printf "%s = %f" sumStr x
      Free -> sumStr

direction :: Direction -> String
direction Minimize = "minimize"
direction Maximize = "maximize"

objective ::
   (Shape.Indexed sh, Shape.Index sh ~ ix, Identifier ix) =>
   Objective sh -> String
objective =
   sum . map (\(ix,c) -> c .* ix) . Array.toAssociations

mathProg ::
   (Shape.Indexed sh, Shape.Index sh ~ ix, Identifier ix) =>
   Bounds ix -> Constraints ix ->
   (Direction, Objective sh) -> [String]
mathProg bounds constrs (dir,obj) =
   map bound bounds ++
   "" :
   direction dir :
   printf "value: %s;" (objective obj) :
   "" :
   "subject to" :
   zipWith
      (\k constr -> printf "constr%d: %s;" k $ constraint constr)
      [(0::Int)..] constrs ++
   "" :
   "end;" :
   []