diff options
Diffstat (limited to 'old')
| -rw-r--r-- | old/Criteria.hs | 93 | ||||
| -rw-r--r-- | old/Storage.hs | 73 | ||||
| -rw-r--r-- | old/preference_arrays.adb | 114 | ||||
| -rw-r--r-- | old/preference_arrays.ads | 38 | ||||
| -rw-r--r-- | old/testmain.hs | 21 |
5 files changed, 0 insertions, 339 deletions
diff --git a/old/Criteria.hs b/old/Criteria.hs deleted file mode 100644 index 8ca19c8..0000000 --- a/old/Criteria.hs +++ /dev/null @@ -1,93 +0,0 @@ -module Criteria( - Criteria, - CTest, - - evaluate, - matchID, - matchFromList, - many - ) where - - - - --- this is a preference criteria checking method modeled after parsec --- it looks nice, and it *does* work, but unfortunately it's far too slow - - - - -import qualified Control.Monad as Con -import qualified Data.List as List -import qualified Data.Either.Unwrap as Either -import qualified Candidate as Typ -import qualified Preferences as Pref - - - - -type Criteria = [CTest] -type CTest = CList -> Either CError CList -type CList = [Typ.CandidateID] -type CError = String - - - - -evaluate :: Typ.BelowLineBallot -> [Pref.Preference] -> Criteria -> Bool -evaluate ballot preferences criteria = - let clist = prefsToCList ballot preferences - parsed = Con.foldM (flip id) clist criteria - result = Either.isRight parsed - in if (isValidInput ballot preferences) - then result - else False - - - - -isValidInput :: Typ.BelowLineBallot -> [Pref.Preference] -> Bool -isValidInput ballot preferences = - all (\(x,y) -> x > 0 && x <= length ballot - && y > 0 && y <= length ballot) preferences - - - - -prefsToCList :: Typ.BelowLineBallot -> [Pref.Preference] -> CList -prefsToCList ballot preferences = - let t0 = map (\(x,y) -> (ballot !! (x - 1), y)) preferences - t1 = List.sortBy (\x y -> compare (snd x) (snd y)) t0 - in map fst t1 - - - - -matchID :: Typ.CandidateID -> CTest -matchID candID = (\x -> - let r = (head x == candID) - in if (length x == 0 || not r) - then Left "Couldn't match candidate" - else Right (tail x)) - - - - -matchFromList :: [Typ.CandidateID] -> CTest -matchFromList candList = (\x -> - let r = (head x) `elem` candList - in if (length x == 0 || not r) - then Left "Couldn't match candidate" - else Right (tail x)) - - - - -many :: CTest -> CTest -many ct = (\x -> - let r = ct x - in if (Either.isRight r) - then many ct (Either.fromRight r) - else Right x) - - diff --git a/old/Storage.hs b/old/Storage.hs deleted file mode 100644 index 2697c39..0000000 --- a/old/Storage.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - -module Storage( - PrefStorage, - createStorage, - pokePref, - peekPref - ) where - - - - -import Foreign -import Foreign.C - - - - -foreign import ccall "create_pref_array" - c_createPrefArray :: CInt -> CInt -> IO (Ptr PrefArray) - -foreign import ccall "free_pref_array" - c_freePrefArray :: CInt -> CInt -> Ptr PrefArray -> IO () - -foreign import ccall "wrapper" - wrap :: (Ptr PrefArray -> IO ()) -> IO (FunPtr (Ptr PrefArray -> IO ())) - -foreign import ccall "poke_pref_array" - c_pokePrefArray :: CInt -> CInt -> Ptr PrefArray -> CInt -> CInt -> CInt -> IO () - -foreign import ccall "peek_pref_array" - c_peekPrefArray :: CInt -> CInt -> Ptr PrefArray -> CInt -> CInt -> CInt -> IO CInt - - - - -newtype PrefArray = PrefArray (Ptr PrefArray) - -data PrefStorage = PrefStorage { pointer :: ForeignPtr PrefArray - , numBallots :: Int - , sizeOfBallot :: Int } - - - - -createStorage :: Int -> Int -> IO PrefStorage -createStorage n s = do - x <- c_createPrefArray (fromIntegral n) (fromIntegral s) - f <- wrap (c_freePrefArray (fromIntegral n) (fromIntegral s)) - y <- newForeignPtr f x - return (PrefStorage y n s) - - - - -pokePref :: PrefStorage -> Int -> Int -> Int -> IO () -pokePref p n s r = do - let numBal = fromIntegral (numBallots p) - sizeBal = fromIntegral (sizeOfBallot p) - func a = c_pokePrefArray numBal sizeBal a (fromIntegral n) (fromIntegral s) (fromIntegral r) - withForeignPtr (pointer p) func - - - - -peekPref :: PrefStorage -> Int -> Int -> Int -> IO Bool -peekPref p n s r = do - let numBal = fromIntegral (numBallots p) - sizeBal = fromIntegral (sizeOfBallot p) - func a = c_peekPrefArray numBal sizeBal a (fromIntegral n) (fromIntegral s) (fromIntegral r) - result <- withForeignPtr (pointer p) func - return (result /= 0) - diff --git a/old/preference_arrays.adb b/old/preference_arrays.adb deleted file mode 100644 index 0b1218a..0000000 --- a/old/preference_arrays.adb +++ /dev/null @@ -1,114 +0,0 @@ - - -with Ada.Unchecked_Deallocation; -with System.Address_To_Access_Conversions; - - -package body Preference_Arrays is - - - type Ranking is range 1 .. 255; - - type Preference_Array is array (Positive range <>, Positive range <>) of Ranking; - pragma Pack (Preference_Array); - - - - - -- these following functions would be a lot smaller and neater - -- if the FFI could make use of fat pointers - - - - - function Create_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int) - return System.Address - is - subtype Constrained is Preference_Array - (1 .. Positive (Number_Of_Ballots), - 1 .. Positive (Size_Of_Ballot)); - - package Convert is new System.Address_To_Access_Conversions - (Object => Constrained); - - Pref_Array : Convert.Object_Pointer; - begin - Pref_Array := new Preference_Array - (1 .. Positive (Number_Of_Ballots), - 1 .. Positive (Size_Of_Ballot)); - return Convert.To_Address (Pref_Array); - end Create_Preference_Array; - - - - - procedure Free_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; - Pref_Array_Address : in System.Address) - is - subtype Constrained is Preference_Array - (1 .. Positive (Number_Of_Ballots), - 1 .. Positive (Size_Of_Ballot)); - - package Convert is new System.Address_To_Access_Conversions - (Object => Constrained); - procedure Free_Pref_Array is new Ada.Unchecked_Deallocation - (Object => Constrained, Name => Convert.Object_Pointer); - - Pref_Array : Convert.Object_Pointer; - begin - Pref_Array := Convert.To_Pointer (Pref_Array_Address); - Free_Pref_Array (Pref_Array); - end Free_Preference_Array; - - - - - procedure Poke_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; - Pref_Array_Address : in System.Address; - Ballot_Index, Box_Number, Rank : in Interfaces.C.int) - is - subtype Constrained is Preference_Array - (1 .. Positive (Number_Of_Ballots), - 1 .. Positive (Size_Of_Ballot)); - - package Convert is new System.Address_To_Access_Conversions - (Object => Constrained); - - Pref_Array : Convert.Object_Pointer; - begin - Pref_Array := Convert.To_Pointer (Pref_Array_Address); - Pref_Array (Positive (Ballot_Index), Positive (Box_Number)) := Ranking (Rank); - end Poke_Preference_Array; - - - - - function Peek_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; - Pref_Array_Address : in System.Address; - Ballot_Index, Box_Number, Rank : in Interfaces.C.int) - return Interfaces.C.int - is - subtype Constrained is Preference_Array - (1 .. Positive (Number_Of_Ballots), - 1 .. Positive (Size_Of_Ballot)); - - package Convert is new System.Address_To_Access_Conversions - (Object => Constrained); - - Pref_Array : Convert.Object_Pointer; - begin - Pref_Array := Convert.To_Pointer (Pref_Array_Address); - if Pref_Array (Positive (Ballot_Index), Positive (Box_Number)) = Ranking (Rank) then - return 1; - else - return 0; - end if; - end Peek_Preference_Array; - - -end Preference_Arrays; - diff --git a/old/preference_arrays.ads b/old/preference_arrays.ads deleted file mode 100644 index c8245e0..0000000 --- a/old/preference_arrays.ads +++ /dev/null @@ -1,38 +0,0 @@ - - -with Interfaces.C; -with System; - - -package Preference_Arrays is - - - function Create_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int) - return System.Address; - pragma Export (C, Create_Preference_Array, "create_pref_array"); - - - procedure Free_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; - Pref_Array_Address : in System.Address); - pragma Export (C, Free_Preference_Array, "free_pref_array"); - - - procedure Poke_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; - Pref_Array_Address : in System.Address; - Ballot_Index, Box_Number, Rank : in Interfaces.C.int); - pragma Export (C, Poke_Preference_Array, "poke_pref_array"); - - - function Peek_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; - Pref_Array_Address : in System.Address; - Ballot_Index, Box_Number, Rank : in Interfaces.C.int) - return Interfaces.C.int; - pragma Export (C, Peek_Preference_Array, "peek_pref_array"); - - -end Preference_Arrays; - diff --git a/old/testmain.hs b/old/testmain.hs deleted file mode 100644 index 3f340c2..0000000 --- a/old/testmain.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - - - -import qualified Storage as Store - - - -foreign import ccall adainit :: IO Int -foreign import ccall adafinal :: IO Int - - - -main = do - adainit - s <- Store.createStorage 10 5 - Store.pokePref s 1 2 3 - r <- Store.peekPref s 1 2 3 - putStrLn (show r) - adafinal - |