Skip to content

Instantly share code, notes, and snippets.

@kindaro
Created March 2, 2023 13:29
Show Gist options
  • Save kindaro/dfc717c14f22ca4776c52d9739dfcfda to your computer and use it in GitHub Desktop.
Save kindaro/dfc717c14f22ca4776c52d9739dfcfda to your computer and use it in GitHub Desktop.
{-# language GHC2021, UnicodeSyntax, BlockArguments, LambdaCase #-}
{-# language AllowAmbiguousTypes #-}
{-# language MonoLocalBinds #-}
import Data.List (nubBy, sortBy)
import Data.Function (on, fix, (&))
import Data.String (IsString (fromString))
import Text.Read (readMaybe)
import Prelude hiding (lookup)
import Prelude qualified
import Control.Applicative (liftA2)
class Ordered label set where ordered ∷ set → set → Ordering
data Default
data Trivial
instance Ord set ⇒ Ordered Default set where ordered = compare
instance Ordered Trivial set where ordered _ _ = EQ
newtype FancyMap (odering ∷ kind) key value = FancyMap {fancyMap ∷ [(key, value)]} deriving (Show)
empty ∷ FancyMap ordering key value
empty = FancyMap [ ]
derivedEquality ∷ ∀ label set. Ordered label set ⇒ set → set → Bool
derivedEquality = fmap (== EQ) . ordered @label
insert
∷ ∀ ordering key value
. Ordered ordering key
⇒ (key, value) → FancyMap ordering key value → FancyMap ordering key value
insert this = FancyMap . nubBy equality . sortBy ordering . (this:) . fancyMap
where
ordering = ordered @ordering `on` fst
equality = derivedEquality @ordering `on` fst
lookup
∷ ∀ ordering key value
. Ordered ordering key
=> FancyMap ordering key value → key → Maybe value
lookup (FancyMap list) givenKey = list & fix \ recurse → \case
((key, value): leftovers) →
if derivedEquality @ordering givenKey key
then Just value
else recurse leftovers
[ ] → Nothing
merge
∷ ∀ ordering key value
. Ordered ordering key
⇒ FancyMap ordering key value → FancyMap ordering key value → FancyMap ordering key value
merge this that = FancyMap ((nubBy equality . sortBy ordering) (fancyMap this ++ fancyMap that))
where
ordering = ordered @ordering `on` fst
equality = derivedEquality @ordering `on` fst
-- λ this = (insert (1, 'b') . insert (2, 'b') . insert (1, 'a')) (empty @Trivial)
-- λ this
-- FancyMap {fancyMap = [(1,'b')]}
-- λ that = (insert (1, 'b') . insert (2, 'b') . insert (1, 'a')) (empty @Default)
-- λ that
-- FancyMap {fancyMap = [(1,'b'),(2,'b')]}
-- λ this `merge` that
--
-- <interactive>:45:14: error:
-- • Couldn't match type ‘Default’ with ‘Trivial’
-- Expected: FancyMap Trivial key Char
-- Actual: FancyMap Default key Char
-- • In the second argument of ‘merge’, namely ‘that’
-- In the expression: this `merge` that
-- In an equation for ‘it’: it = this `merge` that
class Onely label set where
naught ∷ set
weld ∷ set → set → set
data Addition
data Multiplication
instance Monoid set ⇒ Onely Default set where
naught = mempty
weld = mappend
instance Num set ⇒ Onely Addition set where
naught = 0
weld = (+)
instance Num set ⇒ Onely Multiplication set where
naught = 1
weld = (*)
data Polynomial constant variable
= Constant constant
| Variable variable
| Polynomial constant variable :+ Polynomial constant variable
| Polynomial constant variable :× Polynomial constant variable
infixl 6 :+
infixl 7 :×
readEither string = (maybe (Left string) Right . readMaybe) string
instance IsString (Polynomial Integer String) where
fromString = either Variable Constant . readEither
evaluate
∷ ∀ ordering constant variable
. (Onely Addition constant, Onely Multiplication constant, Ordered ordering variable)
⇒ FancyMap ordering variable constant → Polynomial constant variable → Maybe constant
evaluate assignment = fix \ recurse → \case
Constant constant → Just constant
Variable variable → lookup assignment variable
this :+ that → liftA2 (weld @Addition) (recurse this) (recurse that)
this :× that → liftA2 (weld @Multiplication) (recurse this) (recurse that)
-- λ assignment = insert ("x", 10) (empty @Default)
-- λ evaluate @Default @Integer @String assignment ("2" :× "x" :× "x" :+ "3" :× "x" :+ "5")
-- Just 235
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment