MultisetsBuiltin.hs

{-# LANGUAGE OverloadedStrings #-}

module Funcons.Core.Values.Composite.MultisetsBuiltin where

import Funcons.EDSL
import Funcons.Operations hiding (Values,libFromList)
import Funcons.Core.Values.Primitive.BoolBuiltin

import qualified Data.MultiSet as MS

library = libFromList [
        ("multiset-empty", NullaryFuncon (rewritten (Multiset MS.empty)))
    ,   ("sets-to-multiset", ValueOp stepSetsToMultiset)
    ,   ("multiset-to-set", ValueOp stepMultisetToSet)
--    ,   ("multiset-to-list", ValueOp stepMultisetToList)
--    ,   ("list-to-multiset", ValueOp list_to_multiset_op)
    ,   ("multiset-occurrences", ValueOp stepMultisetOccurrences)
    ,   ("multiset-insert", ValueOp stepMultisetInsert)
    ,   ("multiset-delete", ValueOp stepMultisetDelete)
    ,   ("is-submultiset", ValueOp stepIsSubMultiset)
    ]

is_sub_multiset = applyFuncon "is-sub-multiset"
stepIsSubMultiset [Multiset s1, Multiset s2] =
    rewriteTo $ FValue $ tobool (s1 `MS.isSubsetOf`s2)
stepIsSubMultiset vs = sortErr (is_sub_multiset (map FValue vs))
                            "is-sub-multiset not applied to two multisets"

multiset_delete = applyFuncon "multiset-delete"
stepMultisetDelete [Multiset ms, v, vn]
    | Nat n <- upcastNaturals vn = rewriteTo $ FValue $ Multiset (MS.deleteMany v (fromInteger n) ms)
stepMultisetDelete vs = sortErr (multiset_delete (map FValue vs))
    "multiset-delete not applied to a multiset, value and natural number"

multiset_insert = applyFuncon "multiset-insert"
stepMultisetInsert [v, vn, Multiset ms]
    | Nat n <- upcastNaturals vn = rewriteTo $ FValue $ Multiset (MS.insertMany v (fromInteger n) ms)
stepMultisetInsert vs = sortErr (multiset_insert (map FValue vs))
    "multiset-insert not applied to a value, natural number and multiset"

multiset_occurrences = applyFuncon "multiset-occurrences"
stepMultisetOccurrences [v, Multiset ms] = rewriteTo $ int_ (MS.occur v ms)
stepMultisetOccurrences vs = sortErr (multiset_occurrences (map FValue vs))
    "multiset-occurrences not applied to a value and a multiset"

multiset_to_set = applyFuncon "multiset-to-set"
stepMultisetToSet [Multiset ms] = rewriteTo $ FValue $ Set (MS.toSet ms)
stepMultisetToSet vs = sortErr (multiset_to_set (map FValue vs))
    "multiset-to-set not applied to a multiset"

{-
multiset_to_list = applyFuncon "multiset-to-list"
stepMultisetToList [Multiset ms] = rewriteTo $ FValue $ List $ map intPairToNatTuple (MS.toOccurList ms)
  where
    intPairToNatTuple :: (Values,Int) -> Values
    intPairToNatTuple (v,i) = NonEmptyTuple v (Nat $ toInteger i) []
stepMultisetToList vs = sortErr (multiset_to_list (map FValue vs))
    "multiset-to-list not applied to a multiset"

list_to_multiset_op vs@[List xs] = do ps <- mapM natTupleToIntPair xs
                                      rewriteTo $ FValue $ Multiset $ MS.fromOccurList ps
  where
    natTupleToIntPair :: Values -> Rewrite (Values,Int)
    natTupleToIntPair (NonEmptyTuple v m []) | Nat n <- upcastNaturals m = return (v,fromIntegral n)
    natTupleToIntPair _ = sortErr (applyFuncon "list-to-multiset" (fvalues vs))
                                  "list-to-multiset not applied to a list of tuples of values and naturals"
list_to_multiset_op vs = sortErr (applyFuncon "list-to-multiset" (fvalues vs))
                                 "list-to-multiset not applied to a list"
-}


sets_to_multiset = applyFuncon "sets-to-multiset"
stepSetsToMultiset vs
    | all isSet_ vs = rewriteTo $ FValue $ Multiset (MS.unions (map toMS vs))
    | otherwise = sortErr (sets_to_multiset (map FValue vs))
        "sets-to-multiset not applied to sets"
    where   isSet_ (Set _)  = True
            isSet_ _        = False
            toMS (Set s)    = MS.fromSet s
            toMS _          = error "sets-to-multiset"