Sebastian Kreisel 3 years ago
parent
commit
fac149c34e
7 changed files with 141 additions and 0 deletions
  1. 20 0
      LICENSE
  2. 3 0
      README.md
  3. 2 0
      Setup.hs
  4. 21 0
      asocgen.cabal
  5. 2 0
      compile_and_run.sh
  6. 85 0
      src/Main.hs
  7. 8 0
      stack.yaml

+ 20 - 0
LICENSE

@@ -0,0 +1,20 @@
+Copyright (c) 2014 Sebastian Kreisel
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

+ 3 - 0
README.md

@@ -0,0 +1,3 @@
+# Asocgen
+I want to re-discover groups of finite order. For that I need to find
+associative structures. So here I am searching for semigroups in haskell.

+ 2 - 0
Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

+ 21 - 0
asocgen.cabal

@@ -0,0 +1,21 @@
+name:                asocgen
+version:             0.1.0.0
+synopsis:            Generating associative structures
+
+homepage:            http://elfeck.com
+license:             MIT
+license-file:        LICENSE
+author:              Sebastian Kreisel
+maintainer:          kreisel.sebastian@gmail.com
+
+category:            Math
+build-type:          Simple
+cabal-version:       >=1.10
+
+executable asocgen
+  main-is:             Main.hs
+  hs-source-dirs:      src
+  build-depends:       base
+  ghc-options:         -Wall
+  default-language:    Haskell2010
+  default-extensions:  OverloadedStrings

+ 2 - 0
compile_and_run.sh

@@ -0,0 +1,2 @@
+#!/bin/bash
+stack build --file-watch

+ 85 - 0
src/Main.hs

@@ -0,0 +1,85 @@
+module Main where
+
+import Data.List
+import Data.Maybe
+
+type BinOp = (Int -> Int -> Int)
+type MTab = [Int]
+
+set :: [Int]
+set = [0,1,2,3]
+
+maxEle :: Int
+maxEle = maximum set
+
+sizeM :: Int
+sizeM = length set
+
+
+-- Main
+main :: IO ()
+main = do
+  let t0 = genInitial
+  let t1 = upEntry t0 1 1
+  let t2 = upEntryMaybe t1 1 2
+  let t3 = upEntryMaybe t2 1 3
+  case t3 of
+    Nothing -> putStrLn "Nothing"
+    Just t -> printMTab t
+
+
+printMTab :: MTab -> IO ()
+printMTab mtab = putStrLn $ showMTab mtab
+
+showMTab mtab = intercalate "\n" (rows mtab)
+rows mtab = map (\x -> show $ selectRow x mtab) set
+
+-- Basics
+toBinOp :: MTab -> BinOp
+toBinOp = evalMTab
+
+toMTab :: BinOp -> MTab
+toMTab = undefined
+
+evalMTab :: MTab -> Int -> Int -> Int
+evalMTab mtab r c = mtab !! (c + r * sizeM)
+  --where s = floor (sqrt (fromIntegral (length mtab)) :: Double)
+
+getEntry :: MTab -> Int -> Int -> Int
+getEntry = evalMTab
+
+isAsocOn :: BinOp -> Bool
+isAsocOn f = null xs
+  where xs = [a | a <- set, b <- set, c <- set, f (f a b) c /= f a (f b c)]
+
+
+-- Gen
+genInitial :: MTab
+genInitial = concat $ set : (map row (tail set))
+  where row m = m : (replicate (sizeM - 1) (-1))
+
+upEntryMaybe :: Maybe MTab -> Int -> Int -> Maybe MTab
+upEntryMaybe mtab r c | isNothing mtab = Nothing
+                      | otherwise = upEntry (fromJust mtab) r c
+
+upEntry :: MTab -> Int -> Int -> Maybe MTab
+upEntry mtab r c
+  | getEntry mtab r c == maxEle = Nothing
+  | otherwise = fmap (\x -> replaceAtIndex (r * sizeM + c) x mtab) nextB
+  where constr = [0..(getEntry mtab r c)] ++ (selectRow r mtab) ++
+                 (selectCol c mtab)
+        nextB = nextBiggest constr
+
+selectRow ri xs = drop (sizeM * ri) $ take (sizeM * (ri + 1)) xs
+
+selectCol ci xs = map (xs !!) indexList
+  where indexList = map (\x -> x * sizeM + ci) set
+
+replaceAtIndex :: Int -> a -> [a] -> [a]
+replaceAtIndex n item ls = a ++ (item : b)
+  where (a, (_ : b)) = splitAt n ls
+
+nextBiggest :: [Int] -> Maybe Int
+nextBiggest constr | null xs = Nothing
+                   | otherwise = Just $ head xs
+  where xs = [x | x <- set, not $ x `elem` constr]

+ 8 - 0
stack.yaml

@@ -0,0 +1,8 @@
+resolver: lts-7.5
+
+packages:
+  - '.'
+
+extra-deps: []
+flags: {}
+extra-package-dbs: []