From 2fa209275f0e7aead5ba939bbf7ea638945c130f Mon Sep 17 00:00:00 2001 From: Jack Wines Date: Wed, 15 Sep 2021 04:26:46 -0400 Subject: [PATCH] initial commit --- .gitignore | 3 ++ cabal.config | 1 + cabal.project | 3 ++ client/Main.hs | 48 ++++++++++++++++++++++++ default.nix | 10 +++++ rcv-site.cabal | 83 +++++++++++++++++++++++++++++++++++++++++ server/InstantRunoff.hs | 39 +++++++++++++++++++ server/Main.hs | 6 +++ shared/API.hs | 24 ++++++++++++ 9 files changed, 217 insertions(+) create mode 100644 .gitignore create mode 100644 cabal.config create mode 100644 cabal.project create mode 100644 client/Main.hs create mode 100644 default.nix create mode 100644 rcv-site.cabal create mode 100644 server/InstantRunoff.hs create mode 100644 server/Main.hs create mode 100644 shared/API.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..ab65fb4 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +dist-newstyle/** +result/** +dist/** diff --git a/cabal.config b/cabal.config new file mode 100644 index 0000000..ef1b749 --- /dev/null +++ b/cabal.config @@ -0,0 +1 @@ +compiler: ghcjs diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..f5d505c --- /dev/null +++ b/cabal.project @@ -0,0 +1,3 @@ +ignore-project: False +package zlib + flags: -pkg-config +bundled-c-zlib diff --git a/client/Main.hs b/client/Main.hs new file mode 100644 index 0000000..9c5633e --- /dev/null +++ b/client/Main.hs @@ -0,0 +1,48 @@ +-- | Haskell language pragma + +-- | Haskell module declaration +module Main where + +-- | Miso framework import +import Miso +import Miso.String + +-- | Type synonym for an application model +type Model = Int + +-- | Sum type for application events +data Action + = AddOne + | SubtractOne + | NoOp + | SayHelloWorld + deriving (Show, Eq) + +-- | Entry point for a miso application +main :: IO () +main = startApp App {..} + where + initialAction = SayHelloWorld -- initial action to be executed on application load + model = 0 -- initial model + update = updateModel -- update function + view = viewModel -- view function + events = defaultEvents -- default delegated events + subs = [] -- empty subscription list + mountPoint = Nothing -- mount point for application (Nothing defaults to 'body') + logLevel = Off -- used during prerendering to see if the VDOM and DOM are in sync (only used with `miso` function) + +-- | Updates model, optionally introduces side effects +updateModel :: Action -> Model -> Effect Action Model +updateModel AddOne m = noEff (m + 1) +updateModel SubtractOne m = noEff (m - 1) +updateModel NoOp m = noEff m +updateModel SayHelloWorld m = m <# do + putStrLn "Hello World" >> pure NoOp + +-- | Constructs a virtual DOM from a model +viewModel :: Model -> View Action +viewModel x = div_ [] [ + button_ [ onClick AddOne ] [ text "+" ] + , text (ms x) + , button_ [ onClick SubtractOne ] [ text "-" ] + ] diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..39656e1 --- /dev/null +++ b/default.nix @@ -0,0 +1,10 @@ +with (import +( +builtins.fetchGit { + url = "https://github.com/dmjio/miso"; + ref = "master"; + } +) +{}); + +pkgs.haskell.packages.ghcjs.callCabal2nix "rcv-site" ./. {} diff --git a/rcv-site.cabal b/rcv-site.cabal new file mode 100644 index 0000000..6382924 --- /dev/null +++ b/rcv-site.cabal @@ -0,0 +1,83 @@ +name: rcv-site +version: 0.1.0.0 +category: Web +build-type: Simple +cabal-version: >=1.10 + +executable server + main-is: + Main.hs + if impl(ghcjs) + buildable: False + else + default-language: + Haskell2010 + default-extensions: + ScopedTypeVariables, + OverloadedStrings, + OverloadedLists, + TemplateHaskell, + DataKinds, + FlexibleContexts, + FlexibleInstances, + MultiParamTypeClasses, + OverloadedLabels + TypeFamilies, + UndecidableInstances, + RecursiveDo, + RecordWildCards, + RankNTypes, + DuplicateRecordFields, + TupleSections, + TypeOperators, + DeriveGeneric + hs-source-dirs: + server, + shared + build-depends: + base < 5, + aeson, + containers, + http-types, + lucid, + miso, + mtl, + network-uri, + servant, + servant-lucid, + servant-server, + text, + wai, + wai-app-static, + wai-extra, + warp + default-language: + Haskell2010 + + +executable client + main-is: + Main.hs + if !impl(ghcjs) + buildable: False + else + default-extensions: + ScopedTypeVariables, + OverloadedStrings, + OverloadedLists, + RecordWildCards, + DuplicateRecordFields, + DeriveGeneric + ghcjs-options: + -dedupe -DGHCJS_GC_INTERVAL=5000 + hs-source-dirs: + client, + shared + build-depends: + aeson, + base < 5, + containers, + miso, + servant + default-language: + Haskell2010 diff --git a/server/InstantRunoff.hs b/server/InstantRunoff.hs new file mode 100644 index 0000000..766f113 --- /dev/null +++ b/server/InstantRunoff.hs @@ -0,0 +1,39 @@ +module InstantRunoff where +import qualified Data.List as L +import qualified Data.List.NonEmpty as LN +import qualified Data.Map.Strict as M +import qualified Data.Maybe as My +import qualified Data.Set as S +import Data.Ord +import Data.Maybe +import Data.Ratio + + +solve :: Ord a => LN.NonEmpty (LN.NonEmpty a) -> LN.NonEmpty a +solve votes = + case (L.find (\(_, share) -> share > (1 % 2)) . assocs) of + Just (winner, share) -> return winner -- singleton not introduced until base 4.15 + Nothing -> solve . remove $ S.insert noFirstChoice firstChoiceLoser + where + + -- fromList is partial, but inputs that would cause a faliure are caught by the case statement + remove :: S.Set a -> LN.NonEmpty (LN.NonEmpty a) + remove toRemove = LN.fromList . LN.filter null . LN.map (`elem` toRemove) $ votes + + firstChoiceLoser :: a + firstChoiceLoser = L.minimumBy (\(_, a0) (_, a1) -> compare a0 a1) . LN.map LN.head $ voteShares' + + firstChoices :: LN.NonEmpty a + firstChoices = LN.map LN.head $ votes + + voteShares' :: LN.NonEmpty a -> M.Map a (Ratio Int) + voteShares' = voteShares firstChoices + + noFirstChoice :: S.Set a + noFirstChoice = (S.fromList LN.toList . mconcat $ votes) S.\\ (S.fromList . LN.toList $ firstChoices) + +allSame :: Eq a => [a] -> Bool +allSame = (== 1) . LN.length . LN.nub + +voteShares :: Ord a => LN.NonEmpty a -> M.Map a (Ratio Int) +voteShares l = M.map (% (LN.length l)) . M.fromListWith (+) . map (, 1) . LN.toList $ l diff --git a/server/Main.hs b/server/Main.hs new file mode 100644 index 0000000..6e26ce2 --- /dev/null +++ b/server/Main.hs @@ -0,0 +1,6 @@ +module Main where +import qualified InstantRunoff as IR +import qualified API as A + +main :: IO () +main = putStrLn "todo" diff --git a/shared/API.hs b/shared/API.hs new file mode 100644 index 0000000..a542792 --- /dev/null +++ b/shared/API.hs @@ -0,0 +1,24 @@ +module API where + +import Servant.API +import Data.Text (Text) +import Data.Aeson +import qualified Data.List.NonEmpty as LN + +type Ballot = LN.NonEmpty Text + +data Poll = Poll { + question :: Text, + options :: Ballot +} deriving (Generic, Ord, Eq) + +instance FromJSON Poll +instance ToJSON Poll + +instance FromJSON Ballot +instance ToJSON Ballot + +type RCVAPI = + "poll" :> Capture "pollId" :> "vote" :> ReqBody '[JSON] Ballot :> Post '[JSON] () + <|> "poll" :> "create" :> ReqBody '[JSON] Poll :> Post '[JSON] Int + <|> "poll" :> Capture "pollId" :> Get '[JSON] Poll