An introduction to formal analysis of the truth of a sentence
In the scripts below users can change parts of the program. Places where changes can be made are denoted by "<-- CHANGE".
When setting alphabet:
- users can give any list as an alphabet, eg. ([4,7,2,157]::[Int]) or ['a'..'z']. The type ::[Int] is necessary to prevent ambiguity (the same list could be a list of type Float, Double,...).
- the order of elements in the list gives the ordering of letters in the alphabet
- Char type alphabet assumes all letters are lowercase; uppercase letters represent two consecutive identical lowercase ones
- when using non-Char type alphabet the consecutive letters in output will be separated with the symbol "-"
When setting words:
- make sure the words contain an even number of letters
- make sure the words contain only letters from the alphabet, Eg. if the alphabet is abc=lista2abeceda ([4,7,2,157]::[Int]) then a word from it could be x=lista2rijec ([4,4,2,157,4,2]::[Int])
Example 1
For an alphabet {a, b, c, d, e, f, g}, and an order a < b < c < d < e < f < g we can conclude:
- the starting symbol is a, the ending symbol is g, while the center of the alphabet is d;
- the base consists of 49 atoms: {aa, ab, ac,..., ag, ba, bb, bc,..., bg,...,ga,gb,..., gg};
- the M-word x = abbcdddc = aBcDdc is the concatenation of 4 atoms: x = ab · bc · dd · dc;
- dual word of x is x'=gffeddde;
- starting and ending symbols of x are l(x)= a and r(x)=c, and of its dual are l'(x)= g and r'(x) = e;
- shell: q(x) = ac;
- the length of x is given by λ(abbcdddc) = -2;
- compression: as λ(ac) = -2, it follows λ(abbcdddc)= λ(ac), so x = abbcdddc = ac;
- infimum and supremum: d ↓ f = d, f ↑ g = g, l'(x) ↓ r'(x) = e.
{-# START_FILE Linguistic2.hs #-}
-- show
-- /show
{-# LANGUAGE UndecidableInstances, FlexibleInstances, OverlappingInstances, IncoherentInstances #-}
module Linguistic2 where
import Data.Char (chr, isLower, isUpper, ord, toLower, toUpper)
import Data.List (elemIndex, nub)
import Data.Maybe (fromJust)
-- alphabet type definition and constructors
data Slovo a = Slovo a deriving (Eq, Show)
data Abeceda a = Abeceda {unAbeceda :: [Slovo a]} deriving (Eq, Show)
type Rijec a = [Slovo a]
-- |for a list the function constructs the alphabet containing unique elements of the list
lista2abeceda :: Eq a => [a] -> Abeceda a
lista2abeceda xs=Abeceda [Slovo x|x<-nub xs]
-- |for 2 Enum types (like Char) the function constructs the alphabet from first to second one
enum2abeceda :: (Eq a, Enum a) => a -> a -> Abeceda a
enum2abeceda a z=lista2abeceda [a..z]
-- |for a list the function constructs the word containing letters in the list
lista2rijec :: (Show a,Eq a) => [a] -> Rijec a
lista2rijec xs| even (length xs)= [Slovo x|x<-xs]
| otherwise= error("The word "++show xs++" doesn't have an even number of letters.")
-- |for a word the function returns the list of letters in the word
rijec2lista :: Eq a => Rijec a -> [a]
rijec2lista xs= [x|Slovo x<-xs]
elemAbc :: Eq a => Slovo a -> Abeceda a -> Bool
elemAbc s (Abeceda a) = elem s a
elemIndexAbc :: Eq a => Slovo a -> Abeceda a -> Maybe Int
elemIndexAbc s (Abeceda a) = elemIndex s a
sup :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
sup a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) > fromJust(y `elemIndexAbc` a) = x
| otherwise = y
inf :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
inf a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) < fromJust(y `elemIndexAbc` a) = x
| otherwise = y
-- |function converting two consecutive lowercase letters to an uppercase letter
zapisu :: String->String
zapisu []=[]
zapisu [x]=[x]
zapisu (x:y:xs)|isLower x && x==y = toUpper x:zapisu xs
|otherwise=x:zapisu (y:xs)
-- |function converting uppercase letter to two consecutive lowercase letters
zapisl :: String->String
zapisl []=[]
zapisl (x:xs)|isUpper x =x':x':zapisl xs
|otherwise =x:zapisl xs
where x'=toLower x
-- string output of a word
class Show a => Ispisiv a where
ispis :: Show a => Rijec a -> String
ispis []=[]
ispis [Slovo x]=show x
ispis (Slovo x:xs)=show x++"-"++ispis xs
instance Show a => Ispisiv a
instance Ispisiv Char where
ispis=zapisu.ispis'
ispis' :: Rijec Char -> String
ispis' []=[]
ispis' [Slovo x]=[x]
ispis' (Slovo x:xs)=x:ispis' xs
-- functions returning left and right letters of a word
l :: [Slovo a] -> Slovo a
l = head
d :: [Slovo a] -> Slovo a
d = last
-- |function returning a dual of a letter in an alphabet
dual :: Eq a => Abeceda a -> Slovo a -> Slovo a
dual (Abeceda []) s = error("Nema duala - slovo nije u abecedi.")
dual (Abeceda [c]) s | s==c = c
| otherwise = error("No dual - Letter is not from the alphabet.")
dual (Abeceda cs) s | s==lijevi = desni
| s==desni = lijevi
| otherwise = dual (Abeceda (tail (init cs))) s
where lijevi= l cs
desni= d cs
-- functions returning duals of left/right letters of a word
l' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
l' a= (dual a).l
d' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
d' a= (dual a).d
ljuska :: [Slovo a]->[Slovo a]
ljuska xs=[l xs,d xs]
-- |distance between letters in an alphabet
dd :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Int
dd a x y| m==Nothing || n==Nothing = error("Cannot calculate distance. Letter is not from the alphabet.")
| otherwise = abs (fromJust m-fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
-- |word length
duljina :: Eq a => Abeceda a -> Rijec a -> Int
duljina a []=0
duljina a [c]=0
duljina a (c1:c2:cs)= - dd a c1 c2 - duljina a (c2:cs)
-- word shortening
krati1 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter word
krati1 a [p,r,s,t] | duljina a [p,r,s,t]==duljina a [p,t] = [p,t]
| otherwise = [p,r,s,t]
krati1 _ cs = cs
krati2 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter sub-word
krati2 _ [] = []
krati2 a(c:cs) | length kr==2 = kr ++ drop 3 cs
| otherwise = c : krati2 a cs
where kr = ((krati1 a).(take 4)) (c:cs)
krati :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function fully shortening a word
krati a cs | cs/=kr = krati a kr
| otherwise = cs
where kr = krati2 a cs
-- symmetries
opD :: Eq a => Abeceda a -> Rijec a -> Rijec a
opD _ []=[]
opD a (s:t:ys)=dual a s:dual a t:opD a ys
opE :: Eq a => Abeceda a -> Rijec a -> Rijec a
opE _ []=[]
opE a xs=t:s:opE a ys
where n=length xs
t=d xs
s=xs !! (n-2)
ys=take (n-2) xs
--opE a (s:t:ys)=opE a ys++[t,s] --kraće, ali nije po formuli iz teksta
opF :: Eq a => Abeceda a -> Rijec a -> Rijec a
opF a=(opD a).(opE a)
-- permutations
opI :: Eq a => Abeceda a -> Rijec a -> Rijec a
opI a xs=l xs:xs++[d xs]
-- |negation operator
opK :: Eq a => Abeceda a -> Rijec a -> Rijec a
opK a xs=l' a xs:xs++[d' a xs]
opG :: Eq a => Abeceda a -> Rijec a -> Rijec a
opG a xs=d xs:xs++[l xs]
opH :: Eq a => Abeceda a -> Rijec a -> Rijec a
opH a xs=d' a xs:xs++[l' a xs]
-- serial and parallel conjecture operators
opS :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opS a xs ys = inf a (l xs) (l ys) : inf a (l xs) (l ys) : xs ++
[sup a (d xs) (l ys),inf a (d xs) (l ys)] ++ ys ++
[sup a (d xs) (d ys),sup a (d xs) (d ys)]
opP :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opP a xs ys = sup a (l xs) (l ys) : sup a (l xs) (l ys) : xs ++
[inf a (d xs) (l ys),sup a (d xs) (l ys)] ++ ys ++
[inf a (d xs) (d ys),inf a (d xs) (d ys)]
-- |partitions
particija :: Eq a => Abeceda a -> Rijec a -> Char
particija a xs | lijevi>=*lijevi' && desni<=*desni' && lijevi>*desni ='T'
| lijevi<=*lijevi' && desni<=*desni' && not (lijevi==lijevi' || desni==desni') ='A'
| lijevi==lijevi' && desni==desni' ='0'
| lijevi>=*lijevi' && desni>=*desni' && not (lijevi==lijevi' || desni==desni') ='Z'
| lijevi<=*lijevi' && desni>=*desni' && lijevi<*desni ='F'
where lijevi=l xs
desni=d xs
lijevi'=l' a xs
desni'=d' a xs
x >* y| m==Nothing || n==Nothing =error("Letter not in alphabet.")
| otherwise = (fromJust m) > (fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
x >=* y = x >* y || x==y
x <* y = not (x >=* y)
x <=* y = not (x >* y)
-- implications
pimp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pimp a x y=(opK a x) `opP'` y
where opP'=opP a
simp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
simp a x y=(opK a x) `opS'` y
where opS'=opS a
-- equivalencies
pekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pekv a x y=(x `pimp'` y) `opS'` (y `pimp'` x)
where opS'=opS a
pimp'=pimp a
sekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
sekv a x y=(x `simp'` y) `opP'` (y `simp'` x)
where opP'=opP a
simp'=simp a
-- |tautologies and rules
taut :: Eq a => Abeceda a -> Rijec a ->Rijec a -> Rijec a -> [(String,Char)]
taut a x y z= zip
["1.ZAKON ISKLJUCENJA TRECEG",
"2.DUAL ZAKONA ISKLJUCENJA TRECEG",
"3.TRANZITIVNOST IMPLIKACIJE",
"4.DUAL TRANZITIVNOSTI IMPLIKACIJE",
"5.ZAKON DVOSTRUKE NEGACIJE",
"6.ZAKON KONTRAPOZICIJE",
"7.DUAL ZAKONA KONTRAPOZICIJE",
"8.ZAKON APSORPCIJE ILI UPIJANJA",
"9.DUAL ZAKONA APSORPCIJE ILI UPIJANJA",
"10.MODUS PONENDO PONENS",
"11.DUAL MODUSA PONENDO PONENS",
"12.MODUS TOLENDO TOLLENS",
"13.DOKAZ NABRAJANJEM",
"14.DOVODJENJE DO PROTURJECJA"]
(map (particija a) [
x `opP'` (neg x),
x `opS'` (neg x),
((x `pimp'` y) `opS'` (y `pimp'` z)) `pimp'` (x `pimp'` z),
((x `simp'` y) `opP'` (y `simp'` z)) `simp'` (x `simp'` z),
(neg (neg x)) `pekv'` x,
(x `pimp'` y) `pimp'` ((neg y) `pimp'` (neg x)),
(x `simp'` y) `simp'` ((neg y) `simp'` (neg x)),
(x `opP'` (y `opP'` x)) `pimp'` x,
(x `opS'` (y `opS'` x)) `simp'` x,
(x `opS'` (x `pimp'` y)) `pimp'` y,
(x `opP'` (x `simp'` y)) `simp'` y,
((neg x) `opS'` ((neg x) `pimp'` (neg y))) `pimp'` (neg y),
((x `pimp'` z) `opS'` (y `pimp'` z)) `pimp'` ((x `opP'` y) `pimp'` z),
((x `pimp'` y) `opS'` (x `pimp'` (neg y))) `pimp'` (neg x)
]
)
where opP'=opP a
opS'=opS a
pimp'=pimp a
simp'=simp a
pekv'=pekv a
sekv'=sekv a
neg=opK a
{-# START_FILE Main.hs #-}
module Main where
import Linguistic2
main :: IO ()
-- show Alphabet
main=do let {abc=lista2abeceda "abcdefg"} -- <-- CHANGE
-- /show
-- show Word x
let {x=lista2rijec.zapisl $ "aBcDdc"} -- <-- CHANGE
-- In the previous line the part '.zapisl $' is added only for Char type words to convert uppercase letters to lowercase.
-- /show
-- show Dual
putStrLn ("x'= "++ ispis (map (dual abc) x))
-- /show
-- show Starting and ending symbols
putStr ("l(x)= "++ ispis [l x]++", ")
putStr ("r(x)= "++ ispis [d x]++", ")
putStr ("l'(x)= "++ ispis [l' abc x]++", ")
putStrLn ("r'(x)= "++ ispis [d' abc x])
-- /show
-- show Shell
putStrLn ("q(x)= "++ ispis (ljuska x))
-- /show
-- show Length
putStrLn ("λ(x)= "++ show (duljina abc x))
-- /show
-- show Compression
putStrLn (ispis x ++" =zip= "++ ispis (krati abc x))
-- /show
-- show Infimum and supremum
putStrLn ("inf(l'(x),r'(x))= "++ ispis [inf abc (l' abc x) (d' abc x)])
putStrLn ("sup(l'(x),r'(x))= "++ ispis [sup abc (l' abc x) (d' abc x)])
-- /showExample 1 with integer alphabet
{-# START_FILE Linguistic2.hs #-}
-- show
-- /show
{-# LANGUAGE UndecidableInstances, FlexibleInstances, OverlappingInstances, IncoherentInstances #-}
module Linguistic2 where
import Data.Char (chr, isLower, isUpper, ord, toLower, toUpper)
import Data.List (elemIndex, nub)
import Data.Maybe (fromJust)
-- alphabet type definition and constructors
data Slovo a = Slovo a deriving (Eq, Show)
data Abeceda a = Abeceda {unAbeceda :: [Slovo a]} deriving (Eq, Show)
type Rijec a = [Slovo a]
-- |for a list the function constructs the alphabet containing unique elements of the list
lista2abeceda :: Eq a => [a] -> Abeceda a
lista2abeceda xs=Abeceda [Slovo x|x<-nub xs]
-- |for 2 Enum types (like Char) the function constructs the alphabet from first to second one
enum2abeceda :: (Eq a, Enum a) => a -> a -> Abeceda a
enum2abeceda a z=lista2abeceda [a..z]
-- |for a list the function constructs the word containing letters in the list
lista2rijec :: (Show a,Eq a) => [a] -> Rijec a
lista2rijec xs| even (length xs)= [Slovo x|x<-xs]
| otherwise= error("The word "++show xs++" doesn't have an even number of letters.")
-- |for a word the function returns the list of letters in the word
rijec2lista :: Eq a => Rijec a -> [a]
rijec2lista xs= [x|Slovo x<-xs]
elemAbc :: Eq a => Slovo a -> Abeceda a -> Bool
elemAbc s (Abeceda a) = elem s a
elemIndexAbc :: Eq a => Slovo a -> Abeceda a -> Maybe Int
elemIndexAbc s (Abeceda a) = elemIndex s a
sup :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
sup a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) > fromJust(y `elemIndexAbc` a) = x
| otherwise = y
inf :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
inf a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) < fromJust(y `elemIndexAbc` a) = x
| otherwise = y
-- |function converting two consecutive lowercase letters to an uppercase letter
zapisu :: String->String
zapisu []=[]
zapisu [x]=[x]
zapisu (x:y:xs)|isLower x && x==y = toUpper x:zapisu xs
|otherwise=x:zapisu (y:xs)
-- |function converting uppercase letter to two consecutive lowercase letters
zapisl :: String->String
zapisl []=[]
zapisl (x:xs)|isUpper x =x':x':zapisl xs
|otherwise =x:zapisl xs
where x'=toLower x
-- string output of a word
class Show a => Ispisiv a where
ispis :: Show a => Rijec a -> String
ispis []=[]
ispis [Slovo x]=show x
ispis (Slovo x:xs)=show x++"-"++ispis xs
instance Show a => Ispisiv a
instance Ispisiv Char where
ispis=zapisu.ispis'
ispis' :: Rijec Char -> String
ispis' []=[]
ispis' [Slovo x]=[x]
ispis' (Slovo x:xs)=x:ispis' xs
-- functions returning left and right letters of a word
l :: [Slovo a] -> Slovo a
l = head
d :: [Slovo a] -> Slovo a
d = last
-- |function returning a dual of a letter in an alphabet
dual :: Eq a => Abeceda a -> Slovo a -> Slovo a
dual (Abeceda []) s = error("Nema duala - slovo nije u abecedi.")
dual (Abeceda [c]) s | s==c = c
| otherwise = error("No dual - Letter is not from the alphabet.")
dual (Abeceda cs) s | s==lijevi = desni
| s==desni = lijevi
| otherwise = dual (Abeceda (tail (init cs))) s
where lijevi= l cs
desni= d cs
-- functions returning duals of left/right letters of a word
l' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
l' a= (dual a).l
d' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
d' a= (dual a).d
ljuska :: [Slovo a]->[Slovo a]
ljuska xs=[l xs,d xs]
-- |distance between letters in an alphabet
dd :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Int
dd a x y| m==Nothing || n==Nothing = error("Cannot calculate distance. Letter is not from the alphabet.")
| otherwise = abs (fromJust m-fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
-- |word length
duljina :: Eq a => Abeceda a -> Rijec a -> Int
duljina a []=0
duljina a [c]=0
duljina a (c1:c2:cs)= - dd a c1 c2 - duljina a (c2:cs)
-- word shortening
krati1 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter word
krati1 a [p,r,s,t] | duljina a [p,r,s,t]==duljina a [p,t] = [p,t]
| otherwise = [p,r,s,t]
krati1 _ cs = cs
krati2 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter sub-word
krati2 _ [] = []
krati2 a(c:cs) | length kr==2 = kr ++ drop 3 cs
| otherwise = c : krati2 a cs
where kr = ((krati1 a).(take 4)) (c:cs)
krati :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function fully shortening a word
krati a cs | cs/=kr = krati a kr
| otherwise = cs
where kr = krati2 a cs
-- symmetries
opD :: Eq a => Abeceda a -> Rijec a -> Rijec a
opD _ []=[]
opD a (s:t:ys)=dual a s:dual a t:opD a ys
opE :: Eq a => Abeceda a -> Rijec a -> Rijec a
opE _ []=[]
opE a xs=t:s:opE a ys
where n=length xs
t=d xs
s=xs !! (n-2)
ys=take (n-2) xs
--opE a (s:t:ys)=opE a ys++[t,s] --kraće, ali nije po formuli iz teksta
opF :: Eq a => Abeceda a -> Rijec a -> Rijec a
opF a=(opD a).(opE a)
-- permutations
opI :: Eq a => Abeceda a -> Rijec a -> Rijec a
opI a xs=l xs:xs++[d xs]
-- |negation operator
opK :: Eq a => Abeceda a -> Rijec a -> Rijec a
opK a xs=l' a xs:xs++[d' a xs]
opG :: Eq a => Abeceda a -> Rijec a -> Rijec a
opG a xs=d xs:xs++[l xs]
opH :: Eq a => Abeceda a -> Rijec a -> Rijec a
opH a xs=d' a xs:xs++[l' a xs]
-- serial and parallel conjecture operators
opS :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opS a xs ys = inf a (l xs) (l ys) : inf a (l xs) (l ys) : xs ++
[sup a (d xs) (l ys),inf a (d xs) (l ys)] ++ ys ++
[sup a (d xs) (d ys),sup a (d xs) (d ys)]
opP :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opP a xs ys = sup a (l xs) (l ys) : sup a (l xs) (l ys) : xs ++
[inf a (d xs) (l ys),sup a (d xs) (l ys)] ++ ys ++
[inf a (d xs) (d ys),inf a (d xs) (d ys)]
-- |partitions
particija :: Eq a => Abeceda a -> Rijec a -> Char
particija a xs | lijevi>=*lijevi' && desni<=*desni' && lijevi>*desni ='T'
| lijevi<=*lijevi' && desni<=*desni' && not (lijevi==lijevi' || desni==desni') ='A'
| lijevi==lijevi' && desni==desni' ='0'
| lijevi>=*lijevi' && desni>=*desni' && not (lijevi==lijevi' || desni==desni') ='Z'
| lijevi<=*lijevi' && desni>=*desni' && lijevi<*desni ='F'
where lijevi=l xs
desni=d xs
lijevi'=l' a xs
desni'=d' a xs
x >* y| m==Nothing || n==Nothing =error("Letter not in alphabet.")
| otherwise = (fromJust m) > (fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
x >=* y = x >* y || x==y
x <* y = not (x >=* y)
x <=* y = not (x >* y)
-- implications
pimp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pimp a x y=(opK a x) `opP'` y
where opP'=opP a
simp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
simp a x y=(opK a x) `opS'` y
where opS'=opS a
-- equivalencies
pekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pekv a x y=(x `pimp'` y) `opS'` (y `pimp'` x)
where opS'=opS a
pimp'=pimp a
sekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
sekv a x y=(x `simp'` y) `opP'` (y `simp'` x)
where opP'=opP a
simp'=simp a
-- |tautologies and rules
taut :: Eq a => Abeceda a -> Rijec a ->Rijec a -> Rijec a -> [(String,Char)]
taut a x y z= zip
["1.ZAKON ISKLJUCENJA TRECEG",
"2.DUAL ZAKONA ISKLJUCENJA TRECEG",
"3.TRANZITIVNOST IMPLIKACIJE",
"4.DUAL TRANZITIVNOSTI IMPLIKACIJE",
"5.ZAKON DVOSTRUKE NEGACIJE",
"6.ZAKON KONTRAPOZICIJE",
"7.DUAL ZAKONA KONTRAPOZICIJE",
"8.ZAKON APSORPCIJE ILI UPIJANJA",
"9.DUAL ZAKONA APSORPCIJE ILI UPIJANJA",
"10.MODUS PONENDO PONENS",
"11.DUAL MODUSA PONENDO PONENS",
"12.MODUS TOLENDO TOLLENS",
"13.DOKAZ NABRAJANJEM",
"14.DOVODJENJE DO PROTURJECJA"]
(map (particija a) [
x `opP'` (neg x),
x `opS'` (neg x),
((x `pimp'` y) `opS'` (y `pimp'` z)) `pimp'` (x `pimp'` z),
((x `simp'` y) `opP'` (y `simp'` z)) `simp'` (x `simp'` z),
(neg (neg x)) `pekv'` x,
(x `pimp'` y) `pimp'` ((neg y) `pimp'` (neg x)),
(x `simp'` y) `simp'` ((neg y) `simp'` (neg x)),
(x `opP'` (y `opP'` x)) `pimp'` x,
(x `opS'` (y `opS'` x)) `simp'` x,
(x `opS'` (x `pimp'` y)) `pimp'` y,
(x `opP'` (x `simp'` y)) `simp'` y,
((neg x) `opS'` ((neg x) `pimp'` (neg y))) `pimp'` (neg y),
((x `pimp'` z) `opS'` (y `pimp'` z)) `pimp'` ((x `opP'` y) `pimp'` z),
((x `pimp'` y) `opS'` (x `pimp'` (neg y))) `pimp'` (neg x)
]
)
where opP'=opP a
opS'=opS a
pimp'=pimp a
simp'=simp a
pekv'=pekv a
sekv'=sekv a
neg=opK a
{-# START_FILE Main.hs #-}
module Main where
import Linguistic2
main :: IO ()
-- show Alphabet
main=do let {abc=lista2abeceda ([4,7,2,157]::[Int])} -- <-- CHANGE
-- /show
-- show Word x
let {x=lista2rijec ([4,4,2,157,4,2]::[Int])} -- <-- CHANGE
-- /show
-- show Dual
putStrLn ("x'= "++ ispis (map (dual abc) x))
-- /show
-- show Starting and ending symbols
putStr ("l(x)= "++ ispis [l x]++", ")
putStr ("r(x)= "++ ispis [d x]++", ")
putStr ("l'(x)= "++ ispis [l' abc x]++", ")
putStrLn ("r'(x)= "++ ispis [d' abc x])
-- /show
-- show Shell
putStrLn ("q(x)= "++ ispis (ljuska x))
-- /show
-- show Length
putStrLn ("λ(x)= "++ show (duljina abc x))
-- /show
-- show Compression
putStrLn (ispis x ++" =zip= "++ ispis (krati abc x))
-- /show
-- show Infimum and supremum
putStrLn ("inf(l'(x),r'(x))= "++ ispis [inf abc (l' abc x) (d' abc x)])
putStrLn ("sup(l'(x),r'(x))= "++ ispis [sup abc (l' abc x) (d' abc x)])
-- /showExample 2
To visualize the symmetries, we define an alphabet {⊤, |, ⊥}. In the logic algebra these symbols correspond to: truth, uncertainty and falsity, but here their role is to help to visualize that the truth and false symbols are symmetric with respect to the horizontal axis, and the uncertainty symbol with respect to the vertical axis. Operators D, E and F act on M-words over this alphabet as follows:
{-# START_FILE Linguistic2.hs #-}
-- show
-- /show
{-# LANGUAGE UndecidableInstances, FlexibleInstances, OverlappingInstances, IncoherentInstances #-}
module Linguistic2 where
import Data.Char (chr, isLower, isUpper, ord, toLower, toUpper)
import Data.List (elemIndex, nub)
import Data.Maybe (fromJust)
-- alphabet type definition and constructors
data Slovo a = Slovo a deriving (Eq, Show)
data Abeceda a = Abeceda {unAbeceda :: [Slovo a]} deriving (Eq, Show)
type Rijec a = [Slovo a]
-- |for a list the function constructs the alphabet containing unique elements of the list
lista2abeceda :: Eq a => [a] -> Abeceda a
lista2abeceda xs=Abeceda [Slovo x|x<-nub xs]
-- |for 2 Enum types (like Char) the function constructs the alphabet from first to second one
enum2abeceda :: (Eq a, Enum a) => a -> a -> Abeceda a
enum2abeceda a z=lista2abeceda [a..z]
-- |for a list the function constructs the word containing letters in the list
lista2rijec :: (Show a,Eq a) => [a] -> Rijec a
lista2rijec xs| even (length xs)= [Slovo x|x<-xs]
| otherwise= error("The word "++show xs++" doesn't have an even number of letters.")
-- |for a word the function returns the list of letters in the word
rijec2lista :: Eq a => Rijec a -> [a]
rijec2lista xs= [x|Slovo x<-xs]
elemAbc :: Eq a => Slovo a -> Abeceda a -> Bool
elemAbc s (Abeceda a) = elem s a
elemIndexAbc :: Eq a => Slovo a -> Abeceda a -> Maybe Int
elemIndexAbc s (Abeceda a) = elemIndex s a
sup :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
sup a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) > fromJust(y `elemIndexAbc` a) = x
| otherwise = y
inf :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
inf a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) < fromJust(y `elemIndexAbc` a) = x
| otherwise = y
-- |function converting two consecutive lowercase letters to an uppercase letter
zapisu :: String->String
zapisu []=[]
zapisu [x]=[x]
zapisu (x:y:xs)|isLower x && x==y = toUpper x:zapisu xs
|otherwise=x:zapisu (y:xs)
-- |function converting uppercase letter to two consecutive lowercase letters
zapisl :: String->String
zapisl []=[]
zapisl (x:xs)|isUpper x =x':x':zapisl xs
|otherwise =x:zapisl xs
where x'=toLower x
-- string output of a word
class Show a => Ispisiv a where
ispis :: Show a => Rijec a -> String
ispis []=[]
ispis [Slovo x]=show x
ispis (Slovo x:xs)=show x++"-"++ispis xs
instance Show a => Ispisiv a
instance Ispisiv Char where
ispis=zapisu.ispis'
ispis' :: Rijec Char -> String
ispis' []=[]
ispis' [Slovo x]=[x]
ispis' (Slovo x:xs)=x:ispis' xs
-- functions returning left and right letters of a word
l :: [Slovo a] -> Slovo a
l = head
d :: [Slovo a] -> Slovo a
d = last
-- |function returning a dual of a letter in an alphabet
dual :: Eq a => Abeceda a -> Slovo a -> Slovo a
dual (Abeceda []) s = error("Nema duala - slovo nije u abecedi.")
dual (Abeceda [c]) s | s==c = c
| otherwise = error("No dual - Letter is not from the alphabet.")
dual (Abeceda cs) s | s==lijevi = desni
| s==desni = lijevi
| otherwise = dual (Abeceda (tail (init cs))) s
where lijevi= l cs
desni= d cs
-- functions returning duals of left/right letters of a word
l' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
l' a= (dual a).l
d' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
d' a= (dual a).d
ljuska :: [Slovo a]->[Slovo a]
ljuska xs=[l xs,d xs]
-- |distance between letters in an alphabet
dd :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Int
dd a x y| m==Nothing || n==Nothing = error("Cannot calculate distance. Letter is not from the alphabet.")
| otherwise = abs (fromJust m-fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
-- |word length
duljina :: Eq a => Abeceda a -> Rijec a -> Int
duljina a []=0
duljina a [c]=0
duljina a (c1:c2:cs)= - dd a c1 c2 - duljina a (c2:cs)
-- word shortening
krati1 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter word
krati1 a [p,r,s,t] | duljina a [p,r,s,t]==duljina a [p,t] = [p,t]
| otherwise = [p,r,s,t]
krati1 _ cs = cs
krati2 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter sub-word
krati2 _ [] = []
krati2 a(c:cs) | length kr==2 = kr ++ drop 3 cs
| otherwise = c : krati2 a cs
where kr = ((krati1 a).(take 4)) (c:cs)
krati :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function fully shortening a word
krati a cs | cs/=kr = krati a kr
| otherwise = cs
where kr = krati2 a cs
-- symmetries
opD :: Eq a => Abeceda a -> Rijec a -> Rijec a
opD _ []=[]
opD a (s:t:ys)=dual a s:dual a t:opD a ys
opE :: Eq a => Abeceda a -> Rijec a -> Rijec a
opE _ []=[]
opE a xs=t:s:opE a ys
where n=length xs
t=d xs
s=xs !! (n-2)
ys=take (n-2) xs
--opE a (s:t:ys)=opE a ys++[t,s] --kraće, ali nije po formuli iz teksta
opF :: Eq a => Abeceda a -> Rijec a -> Rijec a
opF a=(opD a).(opE a)
-- permutations
opI :: Eq a => Abeceda a -> Rijec a -> Rijec a
opI a xs=l xs:xs++[d xs]
-- |negation operator
opK :: Eq a => Abeceda a -> Rijec a -> Rijec a
opK a xs=l' a xs:xs++[d' a xs]
opG :: Eq a => Abeceda a -> Rijec a -> Rijec a
opG a xs=d xs:xs++[l xs]
opH :: Eq a => Abeceda a -> Rijec a -> Rijec a
opH a xs=d' a xs:xs++[l' a xs]
-- serial and parallel conjecture operators
opS :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opS a xs ys = inf a (l xs) (l ys) : inf a (l xs) (l ys) : xs ++
[sup a (d xs) (l ys),inf a (d xs) (l ys)] ++ ys ++
[sup a (d xs) (d ys),sup a (d xs) (d ys)]
opP :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opP a xs ys = sup a (l xs) (l ys) : sup a (l xs) (l ys) : xs ++
[inf a (d xs) (l ys),sup a (d xs) (l ys)] ++ ys ++
[inf a (d xs) (d ys),inf a (d xs) (d ys)]
-- |partitions
particija :: Eq a => Abeceda a -> Rijec a -> Char
particija a xs | lijevi>=*lijevi' && desni<=*desni' && lijevi>*desni ='T'
| lijevi<=*lijevi' && desni<=*desni' && not (lijevi==lijevi' || desni==desni') ='A'
| lijevi==lijevi' && desni==desni' ='0'
| lijevi>=*lijevi' && desni>=*desni' && not (lijevi==lijevi' || desni==desni') ='Z'
| lijevi<=*lijevi' && desni>=*desni' && lijevi<*desni ='F'
where lijevi=l xs
desni=d xs
lijevi'=l' a xs
desni'=d' a xs
x >* y| m==Nothing || n==Nothing =error("Letter not in alphabet.")
| otherwise = (fromJust m) > (fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
x >=* y = x >* y || x==y
x <* y = not (x >=* y)
x <=* y = not (x >* y)
-- implications
pimp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pimp a x y=(opK a x) `opP'` y
where opP'=opP a
simp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
simp a x y=(opK a x) `opS'` y
where opS'=opS a
-- equivalencies
pekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pekv a x y=(x `pimp'` y) `opS'` (y `pimp'` x)
where opS'=opS a
pimp'=pimp a
sekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
sekv a x y=(x `simp'` y) `opP'` (y `simp'` x)
where opP'=opP a
simp'=simp a
-- |tautologies and rules
taut :: Eq a => Abeceda a -> Rijec a ->Rijec a -> Rijec a -> [(String,Char)]
taut a x y z= zip
["1.ZAKON ISKLJUCENJA TRECEG",
"2.DUAL ZAKONA ISKLJUCENJA TRECEG",
"3.TRANZITIVNOST IMPLIKACIJE",
"4.DUAL TRANZITIVNOSTI IMPLIKACIJE",
"5.ZAKON DVOSTRUKE NEGACIJE",
"6.ZAKON KONTRAPOZICIJE",
"7.DUAL ZAKONA KONTRAPOZICIJE",
"8.ZAKON APSORPCIJE ILI UPIJANJA",
"9.DUAL ZAKONA APSORPCIJE ILI UPIJANJA",
"10.MODUS PONENDO PONENS",
"11.DUAL MODUSA PONENDO PONENS",
"12.MODUS TOLENDO TOLLENS",
"13.DOKAZ NABRAJANJEM",
"14.DOVODJENJE DO PROTURJECJA"]
(map (particija a) [
x `opP'` (neg x),
x `opS'` (neg x),
((x `pimp'` y) `opS'` (y `pimp'` z)) `pimp'` (x `pimp'` z),
((x `simp'` y) `opP'` (y `simp'` z)) `simp'` (x `simp'` z),
(neg (neg x)) `pekv'` x,
(x `pimp'` y) `pimp'` ((neg y) `pimp'` (neg x)),
(x `simp'` y) `simp'` ((neg y) `simp'` (neg x)),
(x `opP'` (y `opP'` x)) `pimp'` x,
(x `opS'` (y `opS'` x)) `simp'` x,
(x `opS'` (x `pimp'` y)) `pimp'` y,
(x `opP'` (x `simp'` y)) `simp'` y,
((neg x) `opS'` ((neg x) `pimp'` (neg y))) `pimp'` (neg y),
((x `pimp'` z) `opS'` (y `pimp'` z)) `pimp'` ((x `opP'` y) `pimp'` z),
((x `pimp'` y) `opS'` (x `pimp'` (neg y))) `pimp'` (neg x)
]
)
where opP'=opP a
opS'=opS a
pimp'=pimp a
simp'=simp a
pekv'=pekv a
sekv'=sekv a
neg=opK a
{-# START_FILE Main.hs #-}
module Main where
import Linguistic2
main :: IO ()
-- show Alphabet
main=do let {abc=lista2abeceda "⊤|⊥"} -- <-- CHANGE
-- /show
-- show Words
let {x=lista2rijec "⊤⊤||⊥⊥||";
y=lista2rijec "⊥⊥||⊤⊤||"; -- <-- CHANGE
z=lista2rijec "||⊤⊤||⊥⊥"}
-- /show
-- show Symmetry operators D, E and F
putStrLn ("D("++ispis x++")= "++ ispis (opD abc x))
putStrLn ("E("++ispis y++")= "++ ispis (opE abc y))
putStrLn ("F("++ispis z++")= "++ ispis (opF abc z))
-- /showExample 3
Let the alphabet be the English alphabet {a,... ,z}. Let x = croatian = croian and y=language = le. Unary operators D, E, F, I, K, G, H applied to these words give the following results:
{-# START_FILE Linguistic2.hs #-}
-- show
-- /show
{-# LANGUAGE UndecidableInstances, FlexibleInstances, OverlappingInstances, IncoherentInstances #-}
module Linguistic2 where
import Data.Char (chr, isLower, isUpper, ord, toLower, toUpper)
import Data.List (elemIndex, nub)
import Data.Maybe (fromJust)
-- alphabet type definition and constructors
data Slovo a = Slovo a deriving (Eq, Show)
data Abeceda a = Abeceda {unAbeceda :: [Slovo a]} deriving (Eq, Show)
type Rijec a = [Slovo a]
-- |for a list the function constructs the alphabet containing unique elements of the list
lista2abeceda :: Eq a => [a] -> Abeceda a
lista2abeceda xs=Abeceda [Slovo x|x<-nub xs]
-- |for 2 Enum types (like Char) the function constructs the alphabet from first to second one
enum2abeceda :: (Eq a, Enum a) => a -> a -> Abeceda a
enum2abeceda a z=lista2abeceda [a..z]
-- |for a list the function constructs the word containing letters in the list
lista2rijec :: (Show a,Eq a) => [a] -> Rijec a
lista2rijec xs| even (length xs)= [Slovo x|x<-xs]
| otherwise= error("The word "++show xs++" doesn't have an even number of letters.")
-- |for a word the function returns the list of letters in the word
rijec2lista :: Eq a => Rijec a -> [a]
rijec2lista xs= [x|Slovo x<-xs]
elemAbc :: Eq a => Slovo a -> Abeceda a -> Bool
elemAbc s (Abeceda a) = elem s a
elemIndexAbc :: Eq a => Slovo a -> Abeceda a -> Maybe Int
elemIndexAbc s (Abeceda a) = elemIndex s a
sup :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
sup a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) > fromJust(y `elemIndexAbc` a) = x
| otherwise = y
inf :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
inf a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) < fromJust(y `elemIndexAbc` a) = x
| otherwise = y
-- |function converting two consecutive lowercase letters to an uppercase letter
zapisu :: String->String
zapisu []=[]
zapisu [x]=[x]
zapisu (x:y:xs)|isLower x && x==y = toUpper x:zapisu xs
|otherwise=x:zapisu (y:xs)
-- |function converting uppercase letter to two consecutive lowercase letters
zapisl :: String->String
zapisl []=[]
zapisl (x:xs)|isUpper x =x':x':zapisl xs
|otherwise =x:zapisl xs
where x'=toLower x
-- string output of a word
class Show a => Ispisiv a where
ispis :: Show a => Rijec a -> String
ispis []=[]
ispis [Slovo x]=show x
ispis (Slovo x:xs)=show x++"-"++ispis xs
instance Show a => Ispisiv a
instance Ispisiv Char where
ispis=zapisu.ispis'
ispis' :: Rijec Char -> String
ispis' []=[]
ispis' [Slovo x]=[x]
ispis' (Slovo x:xs)=x:ispis' xs
-- functions returning left and right letters of a word
l :: [Slovo a] -> Slovo a
l = head
d :: [Slovo a] -> Slovo a
d = last
-- |function returning a dual of a letter in an alphabet
dual :: Eq a => Abeceda a -> Slovo a -> Slovo a
dual (Abeceda []) s = error("Nema duala - slovo nije u abecedi.")
dual (Abeceda [c]) s | s==c = c
| otherwise = error("No dual - Letter is not from the alphabet.")
dual (Abeceda cs) s | s==lijevi = desni
| s==desni = lijevi
| otherwise = dual (Abeceda (tail (init cs))) s
where lijevi= l cs
desni= d cs
-- functions returning duals of left/right letters of a word
l' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
l' a= (dual a).l
d' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
d' a= (dual a).d
ljuska :: [Slovo a]->[Slovo a]
ljuska xs=[l xs,d xs]
-- |distance between letters in an alphabet
dd :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Int
dd a x y| m==Nothing || n==Nothing = error("Cannot calculate distance. Letter is not from the alphabet.")
| otherwise = abs (fromJust m-fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
-- |word length
duljina :: Eq a => Abeceda a -> Rijec a -> Int
duljina a []=0
duljina a [c]=0
duljina a (c1:c2:cs)= - dd a c1 c2 - duljina a (c2:cs)
-- word shortening
krati1 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter word
krati1 a [p,r,s,t] | duljina a [p,r,s,t]==duljina a [p,t] = [p,t]
| otherwise = [p,r,s,t]
krati1 _ cs = cs
krati2 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter sub-word
krati2 _ [] = []
krati2 a(c:cs) | length kr==2 = kr ++ drop 3 cs
| otherwise = c : krati2 a cs
where kr = ((krati1 a).(take 4)) (c:cs)
krati :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function fully shortening a word
krati a cs | cs/=kr = krati a kr
| otherwise = cs
where kr = krati2 a cs
-- symmetries
opD :: Eq a => Abeceda a -> Rijec a -> Rijec a
opD _ []=[]
opD a (s:t:ys)=dual a s:dual a t:opD a ys
opE :: Eq a => Abeceda a -> Rijec a -> Rijec a
opE _ []=[]
opE a xs=t:s:opE a ys
where n=length xs
t=d xs
s=xs !! (n-2)
ys=take (n-2) xs
--opE a (s:t:ys)=opE a ys++[t,s] --kraće, ali nije po formuli iz teksta
opF :: Eq a => Abeceda a -> Rijec a -> Rijec a
opF a=(opD a).(opE a)
-- permutations
opI :: Eq a => Abeceda a -> Rijec a -> Rijec a
opI a xs=l xs:xs++[d xs]
-- |negation operator
opK :: Eq a => Abeceda a -> Rijec a -> Rijec a
opK a xs=l' a xs:xs++[d' a xs]
opG :: Eq a => Abeceda a -> Rijec a -> Rijec a
opG a xs=d xs:xs++[l xs]
opH :: Eq a => Abeceda a -> Rijec a -> Rijec a
opH a xs=d' a xs:xs++[l' a xs]
-- serial and parallel conjecture operators
opS :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opS a xs ys = inf a (l xs) (l ys) : inf a (l xs) (l ys) : xs ++
[sup a (d xs) (l ys),inf a (d xs) (l ys)] ++ ys ++
[sup a (d xs) (d ys),sup a (d xs) (d ys)]
opP :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opP a xs ys = sup a (l xs) (l ys) : sup a (l xs) (l ys) : xs ++
[inf a (d xs) (l ys),sup a (d xs) (l ys)] ++ ys ++
[inf a (d xs) (d ys),inf a (d xs) (d ys)]
-- |partitions
particija :: Eq a => Abeceda a -> Rijec a -> Char
particija a xs | lijevi>=*lijevi' && desni<=*desni' && lijevi>*desni ='T'
| lijevi<=*lijevi' && desni<=*desni' && not (lijevi==lijevi' || desni==desni') ='A'
| lijevi==lijevi' && desni==desni' ='0'
| lijevi>=*lijevi' && desni>=*desni' && not (lijevi==lijevi' || desni==desni') ='Z'
| lijevi<=*lijevi' && desni>=*desni' && lijevi<*desni ='F'
where lijevi=l xs
desni=d xs
lijevi'=l' a xs
desni'=d' a xs
x >* y| m==Nothing || n==Nothing =error("Letter not in alphabet.")
| otherwise = (fromJust m) > (fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
x >=* y = x >* y || x==y
x <* y = not (x >=* y)
x <=* y = not (x >* y)
-- implications
pimp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pimp a x y=(opK a x) `opP'` y
where opP'=opP a
simp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
simp a x y=(opK a x) `opS'` y
where opS'=opS a
-- equivalencies
pekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pekv a x y=(x `pimp'` y) `opS'` (y `pimp'` x)
where opS'=opS a
pimp'=pimp a
sekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
sekv a x y=(x `simp'` y) `opP'` (y `simp'` x)
where opP'=opP a
simp'=simp a
-- |tautologies and rules
taut :: Eq a => Abeceda a -> Rijec a ->Rijec a -> Rijec a -> [(String,Char)]
taut a x y z= zip
["1.ZAKON ISKLJUCENJA TRECEG",
"2.DUAL ZAKONA ISKLJUCENJA TRECEG",
"3.TRANZITIVNOST IMPLIKACIJE",
"4.DUAL TRANZITIVNOSTI IMPLIKACIJE",
"5.ZAKON DVOSTRUKE NEGACIJE",
"6.ZAKON KONTRAPOZICIJE",
"7.DUAL ZAKONA KONTRAPOZICIJE",
"8.ZAKON APSORPCIJE ILI UPIJANJA",
"9.DUAL ZAKONA APSORPCIJE ILI UPIJANJA",
"10.MODUS PONENDO PONENS",
"11.DUAL MODUSA PONENDO PONENS",
"12.MODUS TOLENDO TOLLENS",
"13.DOKAZ NABRAJANJEM",
"14.DOVODJENJE DO PROTURJECJA"]
(map (particija a) [
x `opP'` (neg x),
x `opS'` (neg x),
((x `pimp'` y) `opS'` (y `pimp'` z)) `pimp'` (x `pimp'` z),
((x `simp'` y) `opP'` (y `simp'` z)) `simp'` (x `simp'` z),
(neg (neg x)) `pekv'` x,
(x `pimp'` y) `pimp'` ((neg y) `pimp'` (neg x)),
(x `simp'` y) `simp'` ((neg y) `simp'` (neg x)),
(x `opP'` (y `opP'` x)) `pimp'` x,
(x `opS'` (y `opS'` x)) `simp'` x,
(x `opS'` (x `pimp'` y)) `pimp'` y,
(x `opP'` (x `simp'` y)) `simp'` y,
((neg x) `opS'` ((neg x) `pimp'` (neg y))) `pimp'` (neg y),
((x `pimp'` z) `opS'` (y `pimp'` z)) `pimp'` ((x `opP'` y) `pimp'` z),
((x `pimp'` y) `opS'` (x `pimp'` (neg y))) `pimp'` (neg x)
]
)
where opP'=opP a
opS'=opS a
pimp'=pimp a
simp'=simp a
pekv'=pekv a
sekv'=sekv a
neg=opK a
{-# START_FILE Main.hs #-}
module Main where
import Linguistic2
main :: IO ()
-- show Alphabet
main=do let {abc=lista2abeceda ['a'..'z']} -- <-- CHANGE
-- /show
-- show Words
let {x=lista2rijec "croatian"; y=lista2rijec "language"} -- <-- CHANGE
-- /show
-- show Symmetry operators D, E and F
putStr ("D("++ispis x++")= "++ ispis (opD abc x))
putStrLn (" =zip= "++ (ispis.(krati abc)) (opD abc x))
putStr ("E("++ispis x++")= "++ ispis (opE abc x))
putStrLn (" =zip= "++ (ispis.(krati abc)) (opE abc x))
putStr ("E("++ispis y++")= "++ ispis (opE abc y))
putStrLn (" =zip= "++ (ispis.(krati abc)) (opE abc y))
putStr ("F("++ispis x++")= "++ ispis (opF abc x))
putStrLn (" =zip= "++ (ispis.(krati abc)) (opF abc x))
-- /show
-- show Symmetry operator E applied to words concatenation
putStr ("E("++ispis (x++y)++")= "++ ispis (opE abc (x++y)))
putStrLn (" =zip= "++ (ispis.(krati abc)) (opE abc (x++y)))
-- /show
-- show permutation operators I, K, G and H
putStr ("I("++ispis x++")= "++ ispis (opI abc x))
putStrLn (" =zip= "++ (ispis.(krati abc)) (opI abc x))
putStr ("K("++ispis x++")= "++ ispis (opK abc x))
putStrLn (" =zip= "++ (ispis.(krati abc)) (opK abc x))
putStr ("G("++ispis x++")= "++ ispis (opG abc x))
putStrLn (" =zip= "++ (ispis.(krati abc)) (opG abc x))
putStr ("H("++ispis x++")= "++ ispis (opH abc x))
putStrLn (" =zip= "++ (ispis.(krati abc)) (opH abc x))
-- /show
-- 0-inverzivnost
-- putStr ("E(G("++ispis y++"))= "++ ispis (opE abc (opG abc y)))
-- putStrLn (" =zip= "++ (ispis.(krati abc)) (opE abc (opG abc y)))
-- putStr ("G(E("++ispis y++"))= "++ ispis (opG abc (opE abc y)))
-- putStrLn (" =zip= "++ (ispis.(krati abc)) (opG abc (opE abc y)))Example 4
Let the set of symbols be the English alphabet {a,..., z}. Let x = croatian = croian and y=language = le. Then the serial and parallel connections are given by:
{-# START_FILE Linguistic2.hs #-}
-- show
-- /show
{-# LANGUAGE UndecidableInstances, FlexibleInstances, OverlappingInstances, IncoherentInstances #-}
module Linguistic2 where
import Data.Char (chr, isLower, isUpper, ord, toLower, toUpper)
import Data.List (elemIndex, nub)
import Data.Maybe (fromJust)
-- alphabet type definition and constructors
data Slovo a = Slovo a deriving (Eq, Show)
data Abeceda a = Abeceda {unAbeceda :: [Slovo a]} deriving (Eq, Show)
type Rijec a = [Slovo a]
-- |for a list the function constructs the alphabet containing unique elements of the list
lista2abeceda :: Eq a => [a] -> Abeceda a
lista2abeceda xs=Abeceda [Slovo x|x<-nub xs]
-- |for 2 Enum types (like Char) the function constructs the alphabet from first to second one
enum2abeceda :: (Eq a, Enum a) => a -> a -> Abeceda a
enum2abeceda a z=lista2abeceda [a..z]
-- |for a list the function constructs the word containing letters in the list
lista2rijec :: (Show a,Eq a) => [a] -> Rijec a
lista2rijec xs| even (length xs)= [Slovo x|x<-xs]
| otherwise= error("The word "++show xs++" doesn't have an even number of letters.")
-- |for a word the function returns the list of letters in the word
rijec2lista :: Eq a => Rijec a -> [a]
rijec2lista xs= [x|Slovo x<-xs]
elemAbc :: Eq a => Slovo a -> Abeceda a -> Bool
elemAbc s (Abeceda a) = elem s a
elemIndexAbc :: Eq a => Slovo a -> Abeceda a -> Maybe Int
elemIndexAbc s (Abeceda a) = elemIndex s a
sup :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
sup a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) > fromJust(y `elemIndexAbc` a) = x
| otherwise = y
inf :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
inf a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) < fromJust(y `elemIndexAbc` a) = x
| otherwise = y
-- |function converting two consecutive lowercase letters to an uppercase letter
zapisu :: String->String
zapisu []=[]
zapisu [x]=[x]
zapisu (x:y:xs)|isLower x && x==y = toUpper x:zapisu xs
|otherwise=x:zapisu (y:xs)
-- |function converting uppercase letter to two consecutive lowercase letters
zapisl :: String->String
zapisl []=[]
zapisl (x:xs)|isUpper x =x':x':zapisl xs
|otherwise =x:zapisl xs
where x'=toLower x
-- string output of a word
class Show a => Ispisiv a where
ispis :: Show a => Rijec a -> String
ispis []=[]
ispis [Slovo x]=show x
ispis (Slovo x:xs)=show x++"-"++ispis xs
instance Show a => Ispisiv a
instance Ispisiv Char where
ispis=zapisu.ispis'
ispis' :: Rijec Char -> String
ispis' []=[]
ispis' [Slovo x]=[x]
ispis' (Slovo x:xs)=x:ispis' xs
-- functions returning left and right letters of a word
l :: [Slovo a] -> Slovo a
l = head
d :: [Slovo a] -> Slovo a
d = last
-- |function returning a dual of a letter in an alphabet
dual :: Eq a => Abeceda a -> Slovo a -> Slovo a
dual (Abeceda []) s = error("Nema duala - slovo nije u abecedi.")
dual (Abeceda [c]) s | s==c = c
| otherwise = error("No dual - Letter is not from the alphabet.")
dual (Abeceda cs) s | s==lijevi = desni
| s==desni = lijevi
| otherwise = dual (Abeceda (tail (init cs))) s
where lijevi= l cs
desni= d cs
-- functions returning duals of left/right letters of a word
l' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
l' a= (dual a).l
d' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
d' a= (dual a).d
ljuska :: [Slovo a]->[Slovo a]
ljuska xs=[l xs,d xs]
-- |distance between letters in an alphabet
dd :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Int
dd a x y| m==Nothing || n==Nothing = error("Cannot calculate distance. Letter is not from the alphabet.")
| otherwise = abs (fromJust m-fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
-- |word length
duljina :: Eq a => Abeceda a -> Rijec a -> Int
duljina a []=0
duljina a [c]=0
duljina a (c1:c2:cs)= - dd a c1 c2 - duljina a (c2:cs)
-- word shortening
krati1 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter word
krati1 a [p,r,s,t] | duljina a [p,r,s,t]==duljina a [p,t] = [p,t]
| otherwise = [p,r,s,t]
krati1 _ cs = cs
krati2 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter sub-word
krati2 _ [] = []
krati2 a(c:cs) | length kr==2 = kr ++ drop 3 cs
| otherwise = c : krati2 a cs
where kr = ((krati1 a).(take 4)) (c:cs)
krati :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function fully shortening a word
krati a cs | cs/=kr = krati a kr
| otherwise = cs
where kr = krati2 a cs
-- symmetries
opD :: Eq a => Abeceda a -> Rijec a -> Rijec a
opD _ []=[]
opD a (s:t:ys)=dual a s:dual a t:opD a ys
opE :: Eq a => Abeceda a -> Rijec a -> Rijec a
opE _ []=[]
opE a xs=t:s:opE a ys
where n=length xs
t=d xs
s=xs !! (n-2)
ys=take (n-2) xs
--opE a (s:t:ys)=opE a ys++[t,s] --kraće, ali nije po formuli iz teksta
opF :: Eq a => Abeceda a -> Rijec a -> Rijec a
opF a=(opD a).(opE a)
-- permutations
opI :: Eq a => Abeceda a -> Rijec a -> Rijec a
opI a xs=l xs:xs++[d xs]
-- |negation operator
opK :: Eq a => Abeceda a -> Rijec a -> Rijec a
opK a xs=l' a xs:xs++[d' a xs]
opG :: Eq a => Abeceda a -> Rijec a -> Rijec a
opG a xs=d xs:xs++[l xs]
opH :: Eq a => Abeceda a -> Rijec a -> Rijec a
opH a xs=d' a xs:xs++[l' a xs]
-- serial and parallel conjecture operators
opS :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opS a xs ys = inf a (l xs) (l ys) : inf a (l xs) (l ys) : xs ++
[sup a (d xs) (l ys),inf a (d xs) (l ys)] ++ ys ++
[sup a (d xs) (d ys),sup a (d xs) (d ys)]
opP :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opP a xs ys = sup a (l xs) (l ys) : sup a (l xs) (l ys) : xs ++
[inf a (d xs) (l ys),sup a (d xs) (l ys)] ++ ys ++
[inf a (d xs) (d ys),inf a (d xs) (d ys)]
-- |partitions
particija :: Eq a => Abeceda a -> Rijec a -> Char
particija a xs | lijevi>=*lijevi' && desni<=*desni' && lijevi>*desni ='T'
| lijevi<=*lijevi' && desni<=*desni' && not (lijevi==lijevi' || desni==desni') ='A'
| lijevi==lijevi' && desni==desni' ='0'
| lijevi>=*lijevi' && desni>=*desni' && not (lijevi==lijevi' || desni==desni') ='Z'
| lijevi<=*lijevi' && desni>=*desni' && lijevi<*desni ='F'
where lijevi=l xs
desni=d xs
lijevi'=l' a xs
desni'=d' a xs
x >* y| m==Nothing || n==Nothing =error("Letter not in alphabet.")
| otherwise = (fromJust m) > (fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
x >=* y = x >* y || x==y
x <* y = not (x >=* y)
x <=* y = not (x >* y)
-- implications
pimp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pimp a x y=(opK a x) `opP'` y
where opP'=opP a
simp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
simp a x y=(opK a x) `opS'` y
where opS'=opS a
-- equivalencies
pekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pekv a x y=(x `pimp'` y) `opS'` (y `pimp'` x)
where opS'=opS a
pimp'=pimp a
sekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
sekv a x y=(x `simp'` y) `opP'` (y `simp'` x)
where opP'=opP a
simp'=simp a
-- |tautologies and rules
taut :: Eq a => Abeceda a -> Rijec a ->Rijec a -> Rijec a -> [(String,Char)]
taut a x y z= zip
["1.ZAKON ISKLJUCENJA TRECEG",
"2.DUAL ZAKONA ISKLJUCENJA TRECEG",
"3.TRANZITIVNOST IMPLIKACIJE",
"4.DUAL TRANZITIVNOSTI IMPLIKACIJE",
"5.ZAKON DVOSTRUKE NEGACIJE",
"6.ZAKON KONTRAPOZICIJE",
"7.DUAL ZAKONA KONTRAPOZICIJE",
"8.ZAKON APSORPCIJE ILI UPIJANJA",
"9.DUAL ZAKONA APSORPCIJE ILI UPIJANJA",
"10.MODUS PONENDO PONENS",
"11.DUAL MODUSA PONENDO PONENS",
"12.MODUS TOLENDO TOLLENS",
"13.DOKAZ NABRAJANJEM",
"14.DOVODJENJE DO PROTURJECJA"]
(map (particija a) [
x `opP'` (neg x),
x `opS'` (neg x),
((x `pimp'` y) `opS'` (y `pimp'` z)) `pimp'` (x `pimp'` z),
((x `simp'` y) `opP'` (y `simp'` z)) `simp'` (x `simp'` z),
(neg (neg x)) `pekv'` x,
(x `pimp'` y) `pimp'` ((neg y) `pimp'` (neg x)),
(x `simp'` y) `simp'` ((neg y) `simp'` (neg x)),
(x `opP'` (y `opP'` x)) `pimp'` x,
(x `opS'` (y `opS'` x)) `simp'` x,
(x `opS'` (x `pimp'` y)) `pimp'` y,
(x `opP'` (x `simp'` y)) `simp'` y,
((neg x) `opS'` ((neg x) `pimp'` (neg y))) `pimp'` (neg y),
((x `pimp'` z) `opS'` (y `pimp'` z)) `pimp'` ((x `opP'` y) `pimp'` z),
((x `pimp'` y) `opS'` (x `pimp'` (neg y))) `pimp'` (neg x)
]
)
where opP'=opP a
opS'=opS a
pimp'=pimp a
simp'=simp a
pekv'=pekv a
sekv'=sekv a
neg=opK a
{-# START_FILE Main.hs #-}
module Main where
import Linguistic2
main :: IO ()
-- show Alphabet
main=do let {abc=lista2abeceda ['a'..'z']} -- <-- CHANGE
-- /show
-- show Words
let {x=lista2rijec "croatian"; y=lista2rijec "language"} -- <-- CHANGE
-- /show
let opPa=opP abc; opSa=opS abc
-- show M-conjunction (serial connection, `AND`)
putStr (ispis x++" `AND` "++ ispis y)
putStr (" = "++ ispis (x `opSa` y))
putStrLn (" =zip= "++ (ispis.(krati abc)) (x `opSa` y))
putStr (ispis y++" `AND` "++ ispis x)
putStr (" = "++ ispis (y `opSa` x))
putStrLn (" =zip= "++ (ispis.(krati abc)) (y `opSa` x))
-- /show
-- show M-disjunction (parallel connection, `OR`)
putStr (ispis x++" `OR` "++ ispis y)
putStr (" = "++ ispis (x `opPa` y))
putStr (" =zip= "++ (ispis.(krati abc)) (x `opPa` y))
putStrLn (" =len= "++ show (duljina abc (x `opPa` y)))
putStr (ispis y++" `OR` "++ ispis x)
putStr (" = "++ ispis (y `opPa` x))
putStr (" =zip= "++ (ispis.(krati abc)) (y `opPa` x))
putStrLn (" =len= "++ show (duljina abc (y `opPa` x)))
-- /showExample 5
For alphabet {1,2,3,4,5} partition of base has the following form:
{-# START_FILE Linguistic2.hs #-}
-- show
-- /show
{-# LANGUAGE UndecidableInstances, FlexibleInstances, OverlappingInstances, IncoherentInstances #-}
module Linguistic2 where
import Data.Char (chr, isLower, isUpper, ord, toLower, toUpper)
import Data.List (elemIndex, nub)
import Data.Maybe (fromJust)
-- alphabet type definition and constructors
data Slovo a = Slovo a deriving (Eq, Show)
data Abeceda a = Abeceda {unAbeceda :: [Slovo a]} deriving (Eq, Show)
type Rijec a = [Slovo a]
-- |for a list the function constructs the alphabet containing unique elements of the list
lista2abeceda :: Eq a => [a] -> Abeceda a
lista2abeceda xs=Abeceda [Slovo x|x<-nub xs]
-- |for 2 Enum types (like Char) the function constructs the alphabet from first to second one
enum2abeceda :: (Eq a, Enum a) => a -> a -> Abeceda a
enum2abeceda a z=lista2abeceda [a..z]
-- |for a list the function constructs the word containing letters in the list
lista2rijec :: (Show a,Eq a) => [a] -> Rijec a
lista2rijec xs| even (length xs)= [Slovo x|x<-xs]
| otherwise= error("The word "++show xs++" doesn't have an even number of letters.")
-- |for a word the function returns the list of letters in the word
rijec2lista :: Eq a => Rijec a -> [a]
rijec2lista xs= [x|Slovo x<-xs]
elemAbc :: Eq a => Slovo a -> Abeceda a -> Bool
elemAbc s (Abeceda a) = elem s a
elemIndexAbc :: Eq a => Slovo a -> Abeceda a -> Maybe Int
elemIndexAbc s (Abeceda a) = elemIndex s a
sup :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
sup a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) > fromJust(y `elemIndexAbc` a) = x
| otherwise = y
inf :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
inf a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) < fromJust(y `elemIndexAbc` a) = x
| otherwise = y
-- |function converting two consecutive lowercase letters to an uppercase letter
zapisu :: String->String
zapisu []=[]
zapisu [x]=[x]
zapisu (x:y:xs)|isLower x && x==y = toUpper x:zapisu xs
|otherwise=x:zapisu (y:xs)
-- |function converting uppercase letter to two consecutive lowercase letters
zapisl :: String->String
zapisl []=[]
zapisl (x:xs)|isUpper x =x':x':zapisl xs
|otherwise =x:zapisl xs
where x'=toLower x
-- string output of a word
class Show a => Ispisiv a where
ispis :: Show a => Rijec a -> String
ispis []=[]
ispis [Slovo x]=show x
ispis (Slovo x:xs)=show x++"-"++ispis xs
instance Show a => Ispisiv a
instance Ispisiv Char where
ispis=zapisu.ispis'
ispis' :: Rijec Char -> String
ispis' []=[]
ispis' [Slovo x]=[x]
ispis' (Slovo x:xs)=x:ispis' xs
-- functions returning left and right letters of a word
l :: [Slovo a] -> Slovo a
l = head
d :: [Slovo a] -> Slovo a
d = last
-- |function returning a dual of a letter in an alphabet
dual :: Eq a => Abeceda a -> Slovo a -> Slovo a
dual (Abeceda []) s = error("Nema duala - slovo nije u abecedi.")
dual (Abeceda [c]) s | s==c = c
| otherwise = error("No dual - Letter is not from the alphabet.")
dual (Abeceda cs) s | s==lijevi = desni
| s==desni = lijevi
| otherwise = dual (Abeceda (tail (init cs))) s
where lijevi= l cs
desni= d cs
-- functions returning duals of left/right letters of a word
l' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
l' a= (dual a).l
d' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
d' a= (dual a).d
ljuska :: [Slovo a]->[Slovo a]
ljuska xs=[l xs,d xs]
-- |distance between letters in an alphabet
dd :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Int
dd a x y| m==Nothing || n==Nothing = error("Cannot calculate distance. Letter is not from the alphabet.")
| otherwise = abs (fromJust m-fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
-- |word length
duljina :: Eq a => Abeceda a -> Rijec a -> Int
duljina a []=0
duljina a [c]=0
duljina a (c1:c2:cs)= - dd a c1 c2 - duljina a (c2:cs)
-- word shortening
krati1 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter word
krati1 a [p,r,s,t] | duljina a [p,r,s,t]==duljina a [p,t] = [p,t]
| otherwise = [p,r,s,t]
krati1 _ cs = cs
krati2 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter sub-word
krati2 _ [] = []
krati2 a(c:cs) | length kr==2 = kr ++ drop 3 cs
| otherwise = c : krati2 a cs
where kr = ((krati1 a).(take 4)) (c:cs)
krati :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function fully shortening a word
krati a cs | cs/=kr = krati a kr
| otherwise = cs
where kr = krati2 a cs
-- symmetries
opD :: Eq a => Abeceda a -> Rijec a -> Rijec a
opD _ []=[]
opD a (s:t:ys)=dual a s:dual a t:opD a ys
opE :: Eq a => Abeceda a -> Rijec a -> Rijec a
opE _ []=[]
opE a xs=t:s:opE a ys
where n=length xs
t=d xs
s=xs !! (n-2)
ys=take (n-2) xs
--opE a (s:t:ys)=opE a ys++[t,s] --kraće, ali nije po formuli iz teksta
opF :: Eq a => Abeceda a -> Rijec a -> Rijec a
opF a=(opD a).(opE a)
-- permutations
opI :: Eq a => Abeceda a -> Rijec a -> Rijec a
opI a xs=l xs:xs++[d xs]
-- |negation operator
opK :: Eq a => Abeceda a -> Rijec a -> Rijec a
opK a xs=l' a xs:xs++[d' a xs]
opG :: Eq a => Abeceda a -> Rijec a -> Rijec a
opG a xs=d xs:xs++[l xs]
opH :: Eq a => Abeceda a -> Rijec a -> Rijec a
opH a xs=d' a xs:xs++[l' a xs]
-- serial and parallel conjecture operators
opS :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opS a xs ys = inf a (l xs) (l ys) : inf a (l xs) (l ys) : xs ++
[sup a (d xs) (l ys),inf a (d xs) (l ys)] ++ ys ++
[sup a (d xs) (d ys),sup a (d xs) (d ys)]
opP :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opP a xs ys = sup a (l xs) (l ys) : sup a (l xs) (l ys) : xs ++
[inf a (d xs) (l ys),sup a (d xs) (l ys)] ++ ys ++
[inf a (d xs) (d ys),inf a (d xs) (d ys)]
-- |partitions
particija :: Eq a => Abeceda a -> Rijec a -> Char
particija a xs | lijevi>=*lijevi' && desni<=*desni' && lijevi>*desni ='T'
| lijevi<=*lijevi' && desni<=*desni' && not (lijevi==lijevi' || desni==desni') ='A'
| lijevi==lijevi' && desni==desni' ='0'
| lijevi>=*lijevi' && desni>=*desni' && not (lijevi==lijevi' || desni==desni') ='Z'
| lijevi<=*lijevi' && desni>=*desni' && lijevi<*desni ='F'
where lijevi=l xs
desni=d xs
lijevi'=l' a xs
desni'=d' a xs
x >* y| m==Nothing || n==Nothing =error("Letter not in alphabet.")
| otherwise = (fromJust m) > (fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
x >=* y = x >* y || x==y
x <* y = not (x >=* y)
x <=* y = not (x >* y)
-- implications
pimp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pimp a x y=(opK a x) `opP'` y
where opP'=opP a
simp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
simp a x y=(opK a x) `opS'` y
where opS'=opS a
-- equivalencies
pekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pekv a x y=(x `pimp'` y) `opS'` (y `pimp'` x)
where opS'=opS a
pimp'=pimp a
sekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
sekv a x y=(x `simp'` y) `opP'` (y `simp'` x)
where opP'=opP a
simp'=simp a
-- |tautologies and rules
taut :: Eq a => Abeceda a -> Rijec a ->Rijec a -> Rijec a -> [(String,Char)]
taut a x y z= zip
["1.ZAKON ISKLJUCENJA TRECEG",
"2.DUAL ZAKONA ISKLJUCENJA TRECEG",
"3.TRANZITIVNOST IMPLIKACIJE",
"4.DUAL TRANZITIVNOSTI IMPLIKACIJE",
"5.ZAKON DVOSTRUKE NEGACIJE",
"6.ZAKON KONTRAPOZICIJE",
"7.DUAL ZAKONA KONTRAPOZICIJE",
"8.ZAKON APSORPCIJE ILI UPIJANJA",
"9.DUAL ZAKONA APSORPCIJE ILI UPIJANJA",
"10.MODUS PONENDO PONENS",
"11.DUAL MODUSA PONENDO PONENS",
"12.MODUS TOLENDO TOLLENS",
"13.DOKAZ NABRAJANJEM",
"14.DOVODJENJE DO PROTURJECJA"]
(map (particija a) [
x `opP'` (neg x),
x `opS'` (neg x),
((x `pimp'` y) `opS'` (y `pimp'` z)) `pimp'` (x `pimp'` z),
((x `simp'` y) `opP'` (y `simp'` z)) `simp'` (x `simp'` z),
(neg (neg x)) `pekv'` x,
(x `pimp'` y) `pimp'` ((neg y) `pimp'` (neg x)),
(x `simp'` y) `simp'` ((neg y) `simp'` (neg x)),
(x `opP'` (y `opP'` x)) `pimp'` x,
(x `opS'` (y `opS'` x)) `simp'` x,
(x `opS'` (x `pimp'` y)) `pimp'` y,
(x `opP'` (x `simp'` y)) `simp'` y,
((neg x) `opS'` ((neg x) `pimp'` (neg y))) `pimp'` (neg y),
((x `pimp'` z) `opS'` (y `pimp'` z)) `pimp'` ((x `opP'` y) `pimp'` z),
((x `pimp'` y) `opS'` (x `pimp'` (neg y))) `pimp'` (neg x)
]
)
where opP'=opP a
opS'=opS a
pimp'=pimp a
simp'=simp a
pekv'=pekv a
sekv'=sekv a
neg=opK a
{-# START_FILE Main.hs #-}
module Main where
import Linguistic2
main :: IO ()
-- show Alphabet
main=do let {abc=lista2abeceda ([1..5]::[Int]);} -- <-- CHANGE
-- /show
-- show Base
let {tab=[([x,y],particija abc [x,y])|x <- unAbeceda abc,y <- unAbeceda abc];}
-- /show
-- show Partitioning of base
putStrLn (filter (/='"') (concat [p:": "++show [ispis x|(x,y)<-tab,y==p]++"\n"|p<-['T','A','0','Z','F']]))
-- /showExample 6
Let x=robin, y=chicken, z=penguin, w=cow be animal species, where the first three come from bird species and the last one from mammals. By the evidence of their belonging to the species of birds, we could assign ca to x, ba to y, aa to z, while for w, we can assign the biggest untruth ac from 3-generator M-system. The truths of certain compound statements are:
{-# START_FILE Linguistic2.hs #-}
-- show
-- /show
{-# LANGUAGE UndecidableInstances, FlexibleInstances, OverlappingInstances, IncoherentInstances #-}
module Linguistic2 where
import Data.Char (chr, isLower, isUpper, ord, toLower, toUpper)
import Data.List (elemIndex, nub)
import Data.Maybe (fromJust)
-- alphabet type definition and constructors
data Slovo a = Slovo {unSlovo :: a} deriving (Eq, Show)
data Abeceda a = Abeceda {unAbeceda :: [Slovo a]} deriving (Eq, Show)
type Rijec a = [Slovo a]
-- |for a list the function constructs the alphabet containing unique elements of the list
lista2abeceda :: Eq a => [a] -> Abeceda a
lista2abeceda xs=Abeceda [Slovo x|x<-nub xs]
-- |for 2 Enum types (like Char) the function constructs the alphabet from first to second one
enum2abeceda :: (Eq a, Enum a) => a -> a -> Abeceda a
enum2abeceda a z=lista2abeceda [a..z]
-- |for a list the function constructs the word containing letters in the list
lista2rijec :: (Show a,Eq a) => [a] -> Rijec a
lista2rijec xs| even (length xs)= [Slovo x|x<-xs]
| otherwise= error("The word "++show xs++" doesn't have an even number of letters.")
-- |for a word the function returns the list of letters in the word
rijec2lista :: Eq a => Rijec a -> [a]
rijec2lista xs= [x|Slovo x<-xs]
elemAbc :: Eq a => Slovo a -> Abeceda a -> Bool
elemAbc s (Abeceda a) = elem s a
elemIndexAbc :: Eq a => Slovo a -> Abeceda a -> Maybe Int
elemIndexAbc s (Abeceda a) = elemIndex s a
sup :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
sup a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) > fromJust(y `elemIndexAbc` a) = x
| otherwise = y
inf :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
inf a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) < fromJust(y `elemIndexAbc` a) = x
| otherwise = y
-- |function converting two consecutive lowercase letters to an uppercase letter
zapisu :: String->String
zapisu []=[]
zapisu [x]=[x]
zapisu (x:y:xs)|isLower x && x==y = toUpper x:zapisu xs
|otherwise=x:zapisu (y:xs)
-- |function converting uppercase letter to two consecutive lowercase letters
zapisl :: String->String
zapisl []=[]
zapisl (x:xs)|isUpper x =x':x':zapisl xs
|otherwise =x:zapisl xs
where x'=toLower x
-- string output of a word
class Show a => Ispisiv a where
ispis :: Show a => Rijec a -> String
ispis []=[]
ispis [Slovo x]=show x
ispis (Slovo x:xs)=show x++"-"++ispis xs
instance Show a => Ispisiv a
instance Ispisiv Char where
ispis=zapisu.ispis'
ispis' :: Rijec Char -> String
ispis' []=[]
ispis' [Slovo x]=[x]
ispis' (Slovo x:xs)=x:ispis' xs
-- functions returning left and right letters of a word
l :: [Slovo a] -> Slovo a
l = head
d :: [Slovo a] -> Slovo a
d = last
-- |function returning a dual of a letter in an alphabet
dual :: Eq a => Abeceda a -> Slovo a -> Slovo a
dual (Abeceda []) s = error("Nema duala - slovo nije u abecedi.")
dual (Abeceda [c]) s | s==c = c
| otherwise = error("No dual - Letter is not from the alphabet.")
dual (Abeceda cs) s | s==lijevi = desni
| s==desni = lijevi
| otherwise = dual (Abeceda (tail (init cs))) s
where lijevi= l cs
desni= d cs
-- functions returning duals of left/right letters of a word
l' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
l' a= (dual a).l
d' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
d' a= (dual a).d
ljuska :: [Slovo a]->[Slovo a]
ljuska xs=[l xs,d xs]
-- |distance between letters in an alphabet
dd :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Int
dd a x y| m==Nothing || n==Nothing = error("Cannot calculate distance. Letter is not from the alphabet.")
| otherwise = abs (fromJust m-fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
-- |word length
duljina :: Eq a => Abeceda a -> Rijec a -> Int
duljina a []=0
duljina a [c]=0
duljina a (c1:c2:cs)= - dd a c1 c2 - duljina a (c2:cs)
-- word shortening
krati1 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter word
krati1 a [p,r,s,t] | duljina a [p,r,s,t]==duljina a [p,t] = [p,t]
| otherwise = [p,r,s,t]
krati1 _ cs = cs
krati2 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter sub-word
krati2 _ [] = []
krati2 a(c:cs) | length kr==2 = kr ++ drop 3 cs
| otherwise = c : krati2 a cs
where kr = ((krati1 a).(take 4)) (c:cs)
krati :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function fully shortening a word
krati a cs | cs/=kr = krati a kr
| otherwise = cs
where kr = krati2 a cs
-- symmetries
opD :: Eq a => Abeceda a -> Rijec a -> Rijec a
opD _ []=[]
opD a (s:t:ys)=dual a s:dual a t:opD a ys
opE :: Eq a => Abeceda a -> Rijec a -> Rijec a
opE _ []=[]
opE a xs=t:s:opE a ys
where n=length xs
t=d xs
s=xs !! (n-2)
ys=take (n-2) xs
--opE a (s:t:ys)=opE a ys++[t,s] --kraće, ali nije po formuli iz teksta
opF :: Eq a => Abeceda a -> Rijec a -> Rijec a
opF a=(opD a).(opE a)
-- permutations
opI :: Eq a => Abeceda a -> Rijec a -> Rijec a
opI a xs=l xs:xs++[d xs]
-- |negation operator
opK :: Eq a => Abeceda a -> Rijec a -> Rijec a
opK a xs=l' a xs:xs++[d' a xs]
opG :: Eq a => Abeceda a -> Rijec a -> Rijec a
opG a xs=d xs:xs++[l xs]
opH :: Eq a => Abeceda a -> Rijec a -> Rijec a
opH a xs=d' a xs:xs++[l' a xs]
-- serial and parallel conjecture operators
opS :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opS a xs ys = inf a (l xs) (l ys) : inf a (l xs) (l ys) : xs ++
[sup a (d xs) (l ys),inf a (d xs) (l ys)] ++ ys ++
[sup a (d xs) (d ys),sup a (d xs) (d ys)]
opP :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opP a xs ys = sup a (l xs) (l ys) : sup a (l xs) (l ys) : xs ++
[inf a (d xs) (l ys),sup a (d xs) (l ys)] ++ ys ++
[inf a (d xs) (d ys),inf a (d xs) (d ys)]
-- |partitions
particija :: Eq a => Abeceda a -> Rijec a -> Char
particija a xs | lijevi>=*lijevi' && desni<=*desni' && lijevi>*desni ='T'
| lijevi<=*lijevi' && desni<=*desni' && not (lijevi==lijevi' || desni==desni') ='A'
| lijevi==lijevi' && desni==desni' ='0'
| lijevi>=*lijevi' && desni>=*desni' && not (lijevi==lijevi' || desni==desni') ='Z'
| lijevi<=*lijevi' && desni>=*desni' && lijevi<*desni ='F'
where lijevi=l xs
desni=d xs
lijevi'=l' a xs
desni'=d' a xs
x >* y| m==Nothing || n==Nothing =error("Letter not in alphabet.")
| otherwise = (fromJust m) > (fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
x >=* y = x >* y || x==y
x <* y = not (x >=* y)
x <=* y = not (x >* y)
-- implications
pimp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pimp a x y=(opK a x) `opP'` y
where opP'=opP a
simp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
simp a x y=(opK a x) `opS'` y
where opS'=opS a
-- equivalencies
pekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pekv a x y=(x `pimp'` y) `opS'` (y `pimp'` x)
where opS'=opS a
pimp'=pimp a
sekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
sekv a x y=(x `simp'` y) `opP'` (y `simp'` x)
where opP'=opP a
simp'=simp a
-- |tautologies and rules
taut :: Eq a => Abeceda a -> Rijec a ->Rijec a -> Rijec a -> [(String,Char)]
taut a x y z= zip
["1.ZAKON ISKLJUCENJA TRECEG",
"2.DUAL ZAKONA ISKLJUCENJA TRECEG",
"3.TRANZITIVNOST IMPLIKACIJE",
"4.DUAL TRANZITIVNOSTI IMPLIKACIJE",
"5.ZAKON DVOSTRUKE NEGACIJE",
"6.ZAKON KONTRAPOZICIJE",
"7.DUAL ZAKONA KONTRAPOZICIJE",
"8.ZAKON APSORPCIJE ILI UPIJANJA",
"9.DUAL ZAKONA APSORPCIJE ILI UPIJANJA",
"10.MODUS PONENDO PONENS",
"11.DUAL MODUSA PONENDO PONENS",
"12.MODUS TOLENDO TOLLENS",
"13.DOKAZ NABRAJANJEM",
"14.DOVODJENJE DO PROTURJECJA"]
(map (particija a) [
x `opP'` (neg x),
x `opS'` (neg x),
((x `pimp'` y) `opS'` (y `pimp'` z)) `pimp'` (x `pimp'` z),
((x `simp'` y) `opP'` (y `simp'` z)) `simp'` (x `simp'` z),
(neg (neg x)) `pekv'` x,
(x `pimp'` y) `pimp'` ((neg y) `pimp'` (neg x)),
(x `simp'` y) `simp'` ((neg y) `simp'` (neg x)),
(x `opP'` (y `opP'` x)) `pimp'` x,
(x `opS'` (y `opS'` x)) `simp'` x,
(x `opS'` (x `pimp'` y)) `pimp'` y,
(x `opP'` (x `simp'` y)) `simp'` y,
((neg x) `opS'` ((neg x) `pimp'` (neg y))) `pimp'` (neg y),
((x `pimp'` z) `opS'` (y `pimp'` z)) `pimp'` ((x `opP'` y) `pimp'` z),
((x `pimp'` y) `opS'` (x `pimp'` (neg y))) `pimp'` (neg x)
]
)
where opP'=opP a
opS'=opS a
pimp'=pimp a
simp'=simp a
pekv'=pekv a
sekv'=sekv a
neg=opK a
{-# START_FILE Main.hs #-}
module Main where
import Linguistic2
import Data.Char (toUpper)
main :: IO ()
-- show Alphabet
main=do let {abc=lista2abeceda ['a'..'c']} -- <-- CHANGE
-- /show
-- show Words
let {x= "robin";
y= "chicken"; -- <-- CHANGE
z= "penguin";
w= "cow";
xx=lista2rijec "ca";
yy=lista2rijec "ba"; -- <-- CHANGE
zz=lista2rijec "aa";
ww=lista2rijec "ac";}
-- /show
let {opPa=opP abc; opSa=opS abc;
xxx=head xx:(lista2rijec.zapisl) (map toUpper x)++[last xx];
yyy=head yy:(lista2rijec.zapisl) (map toUpper y)++[last yy];
zzz=head zz:(lista2rijec.zapisl) (map toUpper z)++[last zz];
www=head ww:(lista2rijec.zapisl) (map toUpper w)++[last ww];}
-- show istinitost riječi
putStrLn ("τ("++x++")= τ("++ispis xx++")= "++[particija abc xx])
putStrLn ("τ("++y++")= τ("++ispis yy++")= "++[particija abc yy])
putStrLn ("τ("++z++")= τ("++ispis zz++")= "++[particija abc zz])
putStrLn ("τ("++w++")= τ("++ispis ww++")= "++[particija abc ww])
-- /show
-- show istinitost logičkih funkcija
putStrLn ("τ("++x++"`AND`"++y++"`OR`"++w++")= τ("++ispis xx++"`AND`"++ispis yy++"`OR`"++ispis ww++")= τ("++(ispis.(krati abc)) (xx `opSa` yy)++"`OR`"++ispis ww++")= τ("++(ispis.(krati abc)) (xx `opSa` yy `opPa` ww)++")= "++[particija abc (xx `opSa` yy `opPa` ww)])
putStrLn ("τ("++z++"`OR`"++y++"`AND`"++w++")= τ("++ispis zz++"`OR`"++ispis yy++"`AND`"++ispis ww++")= τ("++(ispis.(krati abc)) (zz `opPa` yy)++"`AND`"++ispis ww++")= τ("++(ispis.(krati abc)) (zz `opPa` yy `opSa` ww)++")= "++[particija abc (zz `opPa` yy `opSa` ww)])
-- /showExample 7
Let us observe the following three statements written in three languages:
- Croatian: SVI LJUDI SU SMRTNI
- English: ALL MEN ARE MORTAL
- French: TOUS LES HOMMES SONT MORTELS
- Croatian: SOKRAT JE ČOVJEK
- English: SOCRATES IS A MAN
- French: SOCRATE EST UN HOMME
- Croatian: SOKRAT JE SMRTAN
- English: SOCRATES IS MORTAL
- French: SOCRATE EST MORTEL
Processing using M-system have the following form:
{-# START_FILE Linguistic2.hs #-}
-- show
-- /show
{-# LANGUAGE UndecidableInstances, FlexibleInstances, OverlappingInstances, IncoherentInstances #-}
module Linguistic2 where
import Data.Char (chr, isLower, isUpper, ord, toLower, toUpper)
import Data.List (elemIndex, nub)
import Data.Maybe (fromJust)
-- alphabet type definition and constructors
data Slovo a = Slovo a deriving (Eq, Show)
data Abeceda a = Abeceda {unAbeceda :: [Slovo a]} deriving (Eq, Show)
type Rijec a = [Slovo a]
-- |for a list the function constructs the alphabet containing unique elements of the list
lista2abeceda :: Eq a => [a] -> Abeceda a
lista2abeceda xs=Abeceda [Slovo x|x<-nub xs]
-- |for 2 Enum types (like Char) the function constructs the alphabet from first to second one
enum2abeceda :: (Eq a, Enum a) => a -> a -> Abeceda a
enum2abeceda a z=lista2abeceda [a..z]
-- |for a list the function constructs the word containing letters in the list
lista2rijec :: (Show a,Eq a) => [a] -> Rijec a
lista2rijec xs| even (length xs)= [Slovo x|x<-xs]
| otherwise= error("The word "++show xs++" doesn't have an even number of letters.")
-- |for a word the function returns the list of letters in the word
rijec2lista :: Eq a => Rijec a -> [a]
rijec2lista xs= [x|Slovo x<-xs]
elemAbc :: Eq a => Slovo a -> Abeceda a -> Bool
elemAbc s (Abeceda a) = elem s a
elemIndexAbc :: Eq a => Slovo a -> Abeceda a -> Maybe Int
elemIndexAbc s (Abeceda a) = elemIndex s a
sup :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
sup a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) > fromJust(y `elemIndexAbc` a) = x
| otherwise = y
inf :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
inf a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) < fromJust(y `elemIndexAbc` a) = x
| otherwise = y
-- |function converting two consecutive lowercase letters to an uppercase letter
zapisu :: String->String
zapisu []=[]
zapisu [x]=[x]
zapisu (x:y:xs)|isLower x && x==y = toUpper x:zapisu xs
|otherwise=x:zapisu (y:xs)
-- |function converting uppercase letter to two consecutive lowercase letters
zapisl :: String->String
zapisl []=[]
zapisl (x:xs)|isUpper x =x':x':zapisl xs
|otherwise =x:zapisl xs
where x'=toLower x
-- string output of a word
class Show a => Ispisiv a where
ispis :: Show a => Rijec a -> String
ispis []=[]
ispis [Slovo x]=show x
ispis (Slovo x:xs)=show x++"-"++ispis xs
instance Show a => Ispisiv a
instance Ispisiv Char where
ispis=zapisu.ispis'
ispis' :: Rijec Char -> String
ispis' []=[]
ispis' [Slovo x]=[x]
ispis' (Slovo x:xs)=x:ispis' xs
-- functions returning left and right letters of a word
l :: [Slovo a] -> Slovo a
l = head
d :: [Slovo a] -> Slovo a
d = last
-- |function returning a dual of a letter in an alphabet
dual :: Eq a => Abeceda a -> Slovo a -> Slovo a
dual (Abeceda []) s = error("Nema duala - slovo nije u abecedi.")
dual (Abeceda [c]) s | s==c = c
| otherwise = error("No dual - Letter is not from the alphabet.")
dual (Abeceda cs) s | s==lijevi = desni
| s==desni = lijevi
| otherwise = dual (Abeceda (tail (init cs))) s
where lijevi= l cs
desni= d cs
-- functions returning duals of left/right letters of a word
l' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
l' a= (dual a).l
d' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
d' a= (dual a).d
ljuska :: [Slovo a]->[Slovo a]
ljuska xs=[l xs,d xs]
-- |distance between letters in an alphabet
dd :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Int
dd a x y| m==Nothing || n==Nothing = error("Cannot calculate distance. Letter is not from the alphabet.")
| otherwise = abs (fromJust m-fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
-- |word length
duljina :: Eq a => Abeceda a -> Rijec a -> Int
duljina a []=0
duljina a [c]=0
duljina a (c1:c2:cs)= - dd a c1 c2 - duljina a (c2:cs)
-- word shortening
krati1 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter word
krati1 a [p,r,s,t] | duljina a [p,r,s,t]==duljina a [p,t] = [p,t]
| otherwise = [p,r,s,t]
krati1 _ cs = cs
krati2 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter sub-word
krati2 _ [] = []
krati2 a(c:cs) | length kr==2 = kr ++ drop 3 cs
| otherwise = c : krati2 a cs
where kr = ((krati1 a).(take 4)) (c:cs)
krati :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function fully shortening a word
krati a cs | cs/=kr = krati a kr
| otherwise = cs
where kr = krati2 a cs
-- symmetries
opD :: Eq a => Abeceda a -> Rijec a -> Rijec a
opD _ []=[]
opD a (s:t:ys)=dual a s:dual a t:opD a ys
opE :: Eq a => Abeceda a -> Rijec a -> Rijec a
opE _ []=[]
opE a xs=t:s:opE a ys
where n=length xs
t=d xs
s=xs !! (n-2)
ys=take (n-2) xs
--opE a (s:t:ys)=opE a ys++[t,s] --kraće, ali nije po formuli iz teksta
opF :: Eq a => Abeceda a -> Rijec a -> Rijec a
opF a=(opD a).(opE a)
-- permutations
opI :: Eq a => Abeceda a -> Rijec a -> Rijec a
opI a xs=l xs:xs++[d xs]
-- |negation operator
opK :: Eq a => Abeceda a -> Rijec a -> Rijec a
opK a xs=l' a xs:xs++[d' a xs]
opG :: Eq a => Abeceda a -> Rijec a -> Rijec a
opG a xs=d xs:xs++[l xs]
opH :: Eq a => Abeceda a -> Rijec a -> Rijec a
opH a xs=d' a xs:xs++[l' a xs]
-- serial and parallel conjecture operators
opS :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opS a xs ys = inf a (l xs) (l ys) : inf a (l xs) (l ys) : xs ++
[sup a (d xs) (l ys),inf a (d xs) (l ys)] ++ ys ++
[sup a (d xs) (d ys),sup a (d xs) (d ys)]
opP :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opP a xs ys = sup a (l xs) (l ys) : sup a (l xs) (l ys) : xs ++
[inf a (d xs) (l ys),sup a (d xs) (l ys)] ++ ys ++
[inf a (d xs) (d ys),inf a (d xs) (d ys)]
-- |partitions
particija :: Eq a => Abeceda a -> Rijec a -> Char
particija a xs | lijevi>=*lijevi' && desni<=*desni' && lijevi>*desni ='T'
| lijevi<=*lijevi' && desni<=*desni' && not (lijevi==lijevi' || desni==desni') ='A'
| lijevi==lijevi' && desni==desni' ='0'
| lijevi>=*lijevi' && desni>=*desni' && not (lijevi==lijevi' || desni==desni') ='Z'
| lijevi<=*lijevi' && desni>=*desni' && lijevi<*desni ='F'
where lijevi=l xs
desni=d xs
lijevi'=l' a xs
desni'=d' a xs
x >* y| m==Nothing || n==Nothing =error("Letter not in alphabet.")
| otherwise = (fromJust m) > (fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
x >=* y = x >* y || x==y
x <* y = not (x >=* y)
x <=* y = not (x >* y)
-- implications
pimp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pimp a x y=(opK a x) `opP'` y
where opP'=opP a
simp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
simp a x y=(opK a x) `opS'` y
where opS'=opS a
-- equivalencies
pekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pekv a x y=(x `pimp'` y) `opS'` (y `pimp'` x)
where opS'=opS a
pimp'=pimp a
sekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
sekv a x y=(x `simp'` y) `opP'` (y `simp'` x)
where opP'=opP a
simp'=simp a
-- |tautologies and rules
taut :: Eq a => Abeceda a -> Rijec a ->Rijec a -> Rijec a -> [(String,Char)]
taut a x y z= zip
["1.The law of excluded middle",
"2.Dual law of excluded middle",
"3.Transitivity of implication",
"4.Dual law of transitivity of implication",
"5.Double negation law",
"6.Contraposition law",
"7.Dual contraposition law",
"8.Absorption law",
"9.Dual absorption Law",
"10.Modus ponendo ponens",
"11.Dual modus ponendo ponens",
"12.Modus tollendo tollens",
"13.Demonstratio per enumerationem",
"14.Proof by contradiction"]
(map (particija a) [
x `opP'` (neg x),
x `opS'` (neg x),
((x `pimp'` y) `opS'` (y `pimp'` z)) `pimp'` (x `pimp'` z),
((x `simp'` y) `opP'` (y `simp'` z)) `simp'` (x `simp'` z),
(neg (neg x)) `pekv'` x,
(x `pimp'` y) `pimp'` ((neg y) `pimp'` (neg x)),
(x `simp'` y) `simp'` ((neg y) `simp'` (neg x)),
(x `opP'` (y `opS'` x)) `pimp'` x,
(x `opS'` (y `opP'` x)) `simp'` x,
(x `opS'` (x `pimp'` y)) `pimp'` y,
(x `opP'` (x `simp'` y)) `simp'` y,
((neg x) `opS'` ((neg x) `pimp'` (neg y))) `pimp'` (neg y),
((x `pimp'` z) `opS'` (y `pimp'` z)) `pimp'` ((x `opP'` y) `pimp'` z),
((x `pimp'` y) `opS'` (x `pimp'` (neg y))) `pimp'` (neg x)
]
)
where opP'=opP a
opS'=opS a
pimp'=pimp a
simp'=simp a
pekv'=pekv a
sekv'=sekv a
neg=opK a
{-# START_FILE Main.hs #-}
module Main where
import Linguistic2
main :: IO ()
-- show Alphabet
main=do let {abc=lista2abeceda ['a'..'z'];} -- <-- CHANGE
-- /show
-- show Words
let {hr=rijeci ("SOKRAT","COVJEK","SMRTAN");
en=rijeci ("SOCRATES","MAN","MORTALS"); -- <-- CHANGE
fr=rijeci ("SOCRATE","HOMME","MORTELS");}
-- /show
let opPa=opP abc; opSa=opS abc; pimpa=pimp abc; simpa=simp abc;
-- show Word partition
putStrLn ("τ"++show (fNaTri ispis hr)++" = "++show (fNaTri (particija abc) hr))
putStrLn ("τ"++show (fNaTri ispis en)++" = "++show (fNaTri (particija abc) en))
putStrLn ("τ"++show (fNaTri ispis fr)++" = "++show (fNaTri (particija abc) fr))
-- /show
putStrLn "\nThe rule of syllogism"
-- show The rule of syllogism
putStrLn "Croatian:"
obrada abc hr
putStrLn "\nEnglish:"
obrada abc en
putStrLn "\nFrench:"
obrada abc fr
-- /show
putStrLn "\nFirst fallacy"
-- show Fallacy
putStrLn "Croatian:"
obrada2 abc hr
putStrLn "\nEnglish:"
obrada2 abc en
putStrLn "\nFrench:"
obrada2 abc fr
-- /show
putStrLn "\nSecond fallacy"
-- show Fallacy
putStrLn "Croatian:"
obrada3 abc hr
putStrLn "\nEnglish:"
obrada3 abc en
putStrLn "\nFrench:"
obrada3 abc fr
-- /show
putStrLn "\nThird fallacy"
-- show Fallacy
putStrLn "Croatian:"
obrada4 abc hr
putStrLn "\nEnglish:"
obrada4 abc en
putStrLn "\nFrench:"
obrada4 abc fr
-- /show
putStrLn "\nFourth fallacy"
-- show Fallacy
putStrLn "Croatian:"
obrada5 abc hr
putStrLn "\nEnglish:"
obrada5 abc en
putStrLn "\nFrench:"
obrada5 abc fr
-- /show
-- show Tautologies
putStrLn ("\nAll tautologies and rules for (x,y,z)="++show (fNaTri ispis hr)++":")
print ((\a (x,y,z)->taut a x y z) abc hr)
-- /show
fNaTri::(a->b)->(a,a,a)->(b,b,b)
fNaTri f (x,y,z)=(f x,f y,f z)
rijeci::(String,String,String)->(Rijec Char,Rijec Char,Rijec Char)
rijeci x=fNaTri (lista2rijec.zapisl) x
obrada :: Abeceda Char->(Rijec Char,Rijec Char,Rijec Char)->IO ()
obrada abc (y,z,x)= do let {pimpa=pimp abc;opSa=opS abc;ispiskr=(ispis.(krati abc));}
putStrLn ("τ((("++ispis y++" -p-> "++ispis z++") `AND` ("++ispis z++" -p-> "++ispis x++")) -p-> ("++ispis y++" -p-> "++ispis x++"))\n =τ(("
++ispiskr (y `pimpa` z)++" `AND` "++ispiskr (z `pimpa` x)++") -p-> "++ispiskr (y `pimpa` x)++")\n =τ("
++ispiskr ((y `pimpa` z) `opSa` (z `pimpa` x))++" -p-> "++ispiskr (y `pimpa` x)++")\n =τ("
++ispiskr (((y `pimpa` z) `opSa` (z `pimpa` x)) `pimpa` (y `pimpa` x))++")\n ="
++[particija abc (((y `pimpa` z) `opSa` (z `pimpa` x)) `pimpa` (y `pimpa` x))])
obrada2 :: Abeceda Char->(Rijec Char,Rijec Char,Rijec Char)->IO ()
obrada2 abc (y,z,x)= do let {pimpa=pimp abc;simpa=simp abc;opSa=opS abc;ispiskr=(ispis.(krati abc));}
putStrLn ("τ((("++ispis y++" -p-> "++ispis z++") `AND` ("++ispis z++" -p-> "++ispis x++")) -s-> ("++ispis y++" -p-> "++ispis x++"))\n =τ(("
++ispiskr (y `pimpa` z)++" `AND` "++ispiskr (z `pimpa` x)++") -s-> "++ispiskr (y `pimpa` x)++")\n =τ("
++ispiskr ((y `pimpa` z) `opSa` (z `pimpa` x))++" -s-> "++ispiskr (y `pimpa` x)++")\n =τ("
++ispiskr (((y `pimpa` z) `opSa` (z `pimpa` x)) `simpa` (y `pimpa` x))++")\n ="
++[particija abc (((y `pimpa` z) `opSa` (z `pimpa` x)) `simpa` (y `pimpa` x))])
obrada3 :: Abeceda Char->(Rijec Char,Rijec Char,Rijec Char)->IO ()
obrada3 abc (y,z,x)= do let {pimpa=pimp abc;simpa=simp abc;opSa=opS abc;ispiskr=(ispis.(krati abc));}
putStrLn ("τ((("++ispis y++" -p-> "++ispis z++") `AND` ("++ispis z++" -p-> "++ispis x++")) -p-> ("++ispis y++" -s-> "++ispis x++"))\n =τ(("
++ispiskr (y `pimpa` z)++" `AND` "++ispiskr (z `pimpa` x)++") -p-> "++ispiskr (y `simpa` x)++")\n =τ("
++ispiskr ((y `pimpa` z) `opSa` (z `pimpa` x))++" -p-> "++ispiskr (y `simpa` x)++")\n =τ("
++ispiskr (((y `pimpa` z) `opSa` (z `pimpa` x)) `pimpa` (y `simpa` x))++")\n ="
++[particija abc (((y `pimpa` z) `opSa` (z `pimpa` x)) `pimpa` (y `simpa` x))])
obrada4 :: Abeceda Char->(Rijec Char,Rijec Char,Rijec Char)->IO ()
obrada4 abc (y,z,x)= do let {pimpa=pimp abc;simpa=simp abc;opSa=opS abc;nega=opK abc;ispiskr=(ispis.(krati abc));}
putStrLn ("τ((("++ispis y++" -p-> "++ispis z++") `AND` ("++ispis z++" -p-> "++ispis x++")) -p-> ¬("++ispis y++" -p-> "++ispis x++"))\n =τ(("
++ispiskr (y `pimpa` z)++" `AND` "++ispiskr (z `pimpa` x)++") -p-> ¬"++ispiskr (y `pimpa` x)++")\n =τ("
++ispiskr ((y `pimpa` z) `opSa` (z `pimpa` x))++" -p-> "++ispiskr (nega (y `pimpa` x))++")\n =τ("
++ispiskr (((y `pimpa` z) `opSa` (z `pimpa` x)) `pimpa` (nega (y `pimpa` x)))++")\n ="
++[particija abc (((y `pimpa` z) `opSa` (z `pimpa` x)) `pimpa` (nega (y `pimpa` x)))])
obrada5 :: Abeceda Char->(Rijec Char,Rijec Char,Rijec Char)->IO ()
obrada5 abc (y,z,x)= do let {pimpa=pimp abc;simpa=simp abc;opSa=opS abc;nega=opK abc;ispiskr=(ispis.(krati abc));}
putStrLn ("τ((("++ispis y++" -p-> "++ispis z++") `AND` ("++ispis z++" -p-> "++ispis x++")) -p-> ("++ispis y++" -p-> ¬("++ispis x++")))\n =τ(("
++ispiskr (y `pimpa` z)++" `AND` "++ispiskr (z `pimpa` x)++") -p-> "++ispiskr (y `pimpa` (nega x))++")\n =τ("
++ispiskr ((y `pimpa` z) `opSa` (z `pimpa` x))++" -p-> "++ispiskr (y `pimpa` (nega x))++")\n =τ("
++ispiskr (((y `pimpa` z) `opSa` (z `pimpa` x)) `pimpa` (y `pimpa` (nega x)))++")\n ="
++[particija abc (((y `pimpa` z) `opSa` (z `pimpa` x)) `pimpa` (y `pimpa` (nega x)))])The rules of inference and tautologies
{-# START_FILE Linguistic2.hs #-}
-- show
-- /show
{-# LANGUAGE UndecidableInstances, FlexibleInstances, OverlappingInstances, IncoherentInstances #-}
module Linguistic2 where
import Data.Char (chr, isLower, isUpper, ord, toLower, toUpper)
import Data.List (elemIndex, nub)
import Data.Maybe (fromJust)
-- alphabet type definition and constructors
data Slovo a = Slovo a deriving (Eq, Show)
data Abeceda a = Abeceda {unAbeceda :: [Slovo a]} deriving (Eq, Show)
type Rijec a = [Slovo a]
-- |for a list the function constructs the alphabet containing unique elements of the list
lista2abeceda :: Eq a => [a] -> Abeceda a
lista2abeceda xs=Abeceda [Slovo x|x<-nub xs]
-- |for 2 Enum types (like Char) the function constructs the alphabet from first to second one
enum2abeceda :: (Eq a, Enum a) => a -> a -> Abeceda a
enum2abeceda a z=lista2abeceda [a..z]
-- |for a list the function constructs the word containing letters in the list
lista2rijec :: (Show a,Eq a) => [a] -> Rijec a
lista2rijec xs| even (length xs)= [Slovo x|x<-xs]
| otherwise= error("The word "++show xs++" doesn't have an even number of letters.")
-- |for a word the function returns the list of letters in the word
rijec2lista :: Eq a => Rijec a -> [a]
rijec2lista xs= [x|Slovo x<-xs]
elemAbc :: Eq a => Slovo a -> Abeceda a -> Bool
elemAbc s (Abeceda a) = elem s a
elemIndexAbc :: Eq a => Slovo a -> Abeceda a -> Maybe Int
elemIndexAbc s (Abeceda a) = elemIndex s a
sup :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
sup a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) > fromJust(y `elemIndexAbc` a) = x
| otherwise = y
inf :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
inf a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) < fromJust(y `elemIndexAbc` a) = x
| otherwise = y
-- |function converting two consecutive lowercase letters to an uppercase letter
zapisu :: String->String
zapisu []=[]
zapisu [x]=[x]
zapisu (x:y:xs)|isLower x && x==y = toUpper x:zapisu xs
|otherwise=x:zapisu (y:xs)
-- |function converting uppercase letter to two consecutive lowercase letters
zapisl :: String->String
zapisl []=[]
zapisl (x:xs)|isUpper x =x':x':zapisl xs
|otherwise =x:zapisl xs
where x'=toLower x
-- string output of a word
class Show a => Ispisiv a where
ispis :: Show a => Rijec a -> String
ispis []=[]
ispis [Slovo x]=show x
ispis (Slovo x:xs)=show x++"-"++ispis xs
instance Show a => Ispisiv a
instance Ispisiv Char where
ispis=zapisu.ispis'
ispis' :: Rijec Char -> String
ispis' []=[]
ispis' [Slovo x]=[x]
ispis' (Slovo x:xs)=x:ispis' xs
-- functions returning left and right letters of a word
l :: [Slovo a] -> Slovo a
l = head
d :: [Slovo a] -> Slovo a
d = last
-- |function returning a dual of a letter in an alphabet
dual :: Eq a => Abeceda a -> Slovo a -> Slovo a
dual (Abeceda []) s = error("Nema duala - slovo nije u abecedi.")
dual (Abeceda [c]) s | s==c = c
| otherwise = error("No dual - Letter is not from the alphabet.")
dual (Abeceda cs) s | s==lijevi = desni
| s==desni = lijevi
| otherwise = dual (Abeceda (tail (init cs))) s
where lijevi= l cs
desni= d cs
-- functions returning duals of left/right letters of a word
l' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
l' a= (dual a).l
d' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
d' a= (dual a).d
ljuska :: [Slovo a]->[Slovo a]
ljuska xs=[l xs,d xs]
-- |distance between letters in an alphabet
dd :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Int
dd a x y| m==Nothing || n==Nothing = error("Cannot calculate distance. Letter is not from the alphabet.")
| otherwise = abs (fromJust m-fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
-- |word length
duljina :: Eq a => Abeceda a -> Rijec a -> Int
duljina a []=0
duljina a [c]=0
duljina a (c1:c2:cs)= - dd a c1 c2 - duljina a (c2:cs)
-- word shortening
krati1 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter word
krati1 a [p,r,s,t] | duljina a [p,r,s,t]==duljina a [p,t] = [p,t]
| otherwise = [p,r,s,t]
krati1 _ cs = cs
krati2 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter sub-word
krati2 _ [] = []
krati2 a(c:cs) | length kr==2 = kr ++ drop 3 cs
| otherwise = c : krati2 a cs
where kr = ((krati1 a).(take 4)) (c:cs)
krati :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function fully shortening a word
krati a cs | cs/=kr = krati a kr
| otherwise = cs
where kr = krati2 a cs
-- symmetries
opD :: Eq a => Abeceda a -> Rijec a -> Rijec a
opD _ []=[]
opD a (s:t:ys)=dual a s:dual a t:opD a ys
opE :: Eq a => Abeceda a -> Rijec a -> Rijec a
opE _ []=[]
opE a xs=t:s:opE a ys
where n=length xs
t=d xs
s=xs !! (n-2)
ys=take (n-2) xs
--opE a (s:t:ys)=opE a ys++[t,s] --kraće, ali nije po formuli iz teksta
opF :: Eq a => Abeceda a -> Rijec a -> Rijec a
opF a=(opD a).(opE a)
-- permutations
opI :: Eq a => Abeceda a -> Rijec a -> Rijec a
opI a xs=l xs:xs++[d xs]
-- |negation operator
opK :: Eq a => Abeceda a -> Rijec a -> Rijec a
opK a xs=l' a xs:xs++[d' a xs]
opG :: Eq a => Abeceda a -> Rijec a -> Rijec a
opG a xs=d xs:xs++[l xs]
opH :: Eq a => Abeceda a -> Rijec a -> Rijec a
opH a xs=d' a xs:xs++[l' a xs]
-- serial and parallel conjecture operators
opS :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opS a xs ys = inf a (l xs) (l ys) : inf a (l xs) (l ys) : xs ++
[sup a (d xs) (l ys),inf a (d xs) (l ys)] ++ ys ++
[sup a (d xs) (d ys),sup a (d xs) (d ys)]
opP :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opP a xs ys = sup a (l xs) (l ys) : sup a (l xs) (l ys) : xs ++
[inf a (d xs) (l ys),sup a (d xs) (l ys)] ++ ys ++
[inf a (d xs) (d ys),inf a (d xs) (d ys)]
-- |partitions
particija :: Eq a => Abeceda a -> Rijec a -> Char
particija a xs | lijevi>=*lijevi' && desni<=*desni' && lijevi>*desni ='T'
| lijevi<=*lijevi' && desni<=*desni' && not (lijevi==lijevi' || desni==desni') ='A'
| lijevi==lijevi' && desni==desni' ='0'
| lijevi>=*lijevi' && desni>=*desni' && not (lijevi==lijevi' || desni==desni') ='Z'
| lijevi<=*lijevi' && desni>=*desni' && lijevi<*desni ='F'
where lijevi=l xs
desni=d xs
lijevi'=l' a xs
desni'=d' a xs
x >* y| m==Nothing || n==Nothing =error("Letter not in alphabet.")
| otherwise = (fromJust m) > (fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
x >=* y = x >* y || x==y
x <* y = not (x >=* y)
x <=* y = not (x >* y)
-- implications
pimp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pimp a x y=(opK a x) `opP'` y
where opP'=opP a
simp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
simp a x y=(opK a x) `opS'` y
where opS'=opS a
-- equivalencies
pekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pekv a x y=(x `pimp'` y) `opS'` (y `pimp'` x)
where opS'=opS a
pimp'=pimp a
sekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
sekv a x y=(x `simp'` y) `opP'` (y `simp'` x)
where opP'=opP a
simp'=simp a
-- |tautologies and rules
taut :: Eq a => Abeceda a -> Rijec a ->Rijec a -> Rijec a -> [(String,Char)]
taut a x y z= zip
["1.The law of excluded middle (Tertium non datur)",
"2.Dual law of excluded middle (The law of non-contradiction)",
"3.Transitivity of implication (The rule of syllogism)",
"4.Dual low of transitivity of implication",
"5.Double negation row",
"6.Contraposition law",
"7.Dual contraposition law",
"8.Absorption law",
"9.Dual absorption Law",
"10.Modus ponendo ponens",
"11.Dual modus ponendo ponens",
"12.Modus tollendo tollens",
"13.Demonstratio per enumerationem",
"14.Proof by contradiction (Reductio ad apsurdum)"]
(map (particija a) [
x `opP'` (neg x),
x `opS'` (neg x),
((x `pimp'` y) `opS'` (y `pimp'` z)) `pimp'` (x `pimp'` z),
((x `simp'` y) `opP'` (y `simp'` z)) `simp'` (x `simp'` z),
(neg (neg x)) `pekv'` x,
(x `pimp'` y) `pimp'` ((neg y) `pimp'` (neg x)),
(x `simp'` y) `simp'` ((neg y) `simp'` (neg x)),
(x `opP'` (y `opP'` x)) `pimp'` x,
(x `opS'` (y `opS'` x)) `simp'` x,
(x `opS'` (x `pimp'` y)) `pimp'` y,
(x `opP'` (x `simp'` y)) `simp'` y,
((neg x) `opS'` ((neg x) `pimp'` (neg y))) `pimp'` (neg y),
((x `pimp'` z) `opS'` (y `pimp'` z)) `pimp'` ((x `opP'` y) `pimp'` z),
((x `pimp'` y) `opS'` (x `pimp'` (neg y))) `pimp'` (neg x)
]
)
where opP'=opP a
opS'=opS a
pimp'=pimp a
simp'=simp a
pekv'=pekv a
sekv'=sekv a
neg=opK a
{-# START_FILE Main.hs #-}
module Main where
import Linguistic2
main :: IO ()
-- show Alphabet
main=do let {abc=lista2abeceda ['a'..'z']} -- <-- CHANGE
-- /show
-- show Words
let {x=lista2rijec (zapisl "BIRD");
y=lista2rijec (zapisl "PINGU"); -- <-- CHANGE
z=lista2rijec (zapisl "PENGUIN");
w=lista2rijec (zapisl "CHICKEN");}
-- /show
let {opPa=opP abc; opSa=opS abc; pimpa=pimp abc; simpa=simp abc; pekva=pekv abc; nega=opK abc; ispiskr=(ispis.(krati abc));}
-- show Word partition
putStrLn ("τ("++ispis x++")= "++[particija abc x])
putStrLn ("τ("++ispis y++")= "++[particija abc y])
putStrLn ("τ("++ispis z++")= "++[particija abc z])
putStrLn ("τ("++ispis w++")= "++[particija abc w])
-- /show
-- show 1. The law of excluded middle
putStrLn "The law of excluded middle"
putStrLn ("τ("++ispis x++" `OR` ¬("++ispis x++"))\n =τ("
++ispis x++" `OR` "++ispiskr (nega x)++")\n =τ("
++ispiskr (x `opPa` (nega x))++")\n ="
++[particija abc (x `opPa` (nega x))])
-- /show
-- show 2. Dual law of excluded middle
putStrLn "Dual law of excluded middle"
putStrLn ("τ("++ispis x++" `AND` ¬("++ispis x++"))\n =τ("
++ispis x++" `AND` "++ispiskr (nega x)++")\n =τ("
++ispiskr (x `opSa` (nega x))++")\n ="
++[particija abc (x `opSa` (nega x))])
-- /show
-- show 3. Transitivity of implication
putStrLn "Transitivity of implication"
putStrLn ("τ((("++ispis y++" -p-> "++ispis z++") `AND` ("++ispis z++" -p-> "++ispis x++")) -p-> ("++ispis y++" -p-> "++ispis x++"))\n =τ(("
++ispiskr (y `pimpa` z)++" `AND` "++ispiskr (z `pimpa` x)++") -p-> "++ispiskr (y `pimpa` x)++")\n =τ("
++ispiskr ((y `pimpa` z) `opSa` (z `pimpa` x))++" -p-> "++ispiskr (y `pimpa` x)++")\n =τ("
++ispiskr (((y `pimpa` z) `opSa` (z `pimpa` x)) `pimpa` (y `pimpa` x))++")\n ="
++[particija abc (((y `pimpa` z) `opSa` (z `pimpa` x)) `pimpa` (y `pimpa` x))])
-- /show
-- show 4. Dual law of transitivity of implication
putStrLn "Dual law of transitivity of implication"
putStrLn ("τ((("++ispis y++" -s-> "++ispis z++") `OR` ("++ispis z++" -s-> "++ispis x++")) -s-> ("++ispis y++" -s-> "++ispis x++"))\n =τ(("
++ispiskr (y `simpa` z)++" `OR` "++ispiskr (z `simpa` x)++") -s-> "++ispiskr (y `simpa` x)++")\n =τ("
++ispiskr ((y `simpa` z) `opPa` (z `simpa` x))++" -s-> "++ispiskr (y `simpa` x)++")\n =τ("
++ispiskr (((y `simpa` z) `opPa` (z `simpa` x)) `pimpa` (y `pimpa` x))++")\n ="
++[particija abc (((y `simpa` z) `opPa` (z `simpa` x)) `simpa` (y `simpa` x))])
-- /show
-- show 5. Double negation law
putStrLn "Double negation law"
putStrLn ("τ(¬(¬("++ispis x++")) <=p=> "++ispis x++")\n =τ(¬("
++ispiskr (nega x)++") <=p=> "++ispis x++")\n =τ("
++ispiskr (nega (nega x))++" <=p=> "++ispis x++")\n =τ("
++ispiskr ((nega (nega x)) `pekva` x)++")\n ="
++[particija abc ((nega (nega x)) `pekva` x)])
-- /show
-- show 6. Contraposition law
putStrLn "Contraposition law"
putStrLn ("τ(("++ispis w++" -p-> "++ispis x++") -p-> (¬("++ispis x++") -p-> ¬("++ispis w++")))\n =τ("
++ispiskr (w `pimpa` x)++" -p-> ("++ispis (nega x)++" -p-> "++ispis (nega w)++"))\n =τ("
++ispiskr (w `pimpa` x)++" -p-> "++ispiskr ((nega x) `pimpa` (nega w))++")\n =τ("
++ispiskr ((w `pimpa` x) `pimpa` ((nega x) `pimpa` (nega w)))++")\n ="
++[particija abc ((w `pimpa` x) `pimpa` ((nega x) `pimpa` (nega w)))])
-- /show
-- show 7. Dual contraposition law
putStrLn "Dual contraposition law"
putStrLn ("τ(("++ispis w++" -s-> "++ispis x++") -s-> (¬("++ispis x++") -s-> ¬("++ispis w++")))\n =τ("
++ispiskr (w `simpa` x)++" -s-> ("++ispis (nega x)++" -s-> "++ispis (nega w)++"))\n =τ("
++ispiskr (w `simpa` x)++" -s-> "++ispiskr ((nega x) `simpa` (nega w))++")\n =τ("
++ispiskr ((w `simpa` x) `simpa` ((nega x) `simpa` (nega w)))++")\n ="
++[particija abc ((w `simpa` x) `simpa` ((nega x) `simpa` (nega w)))])
-- /show
-- show 8. Absorption law
putStrLn "Absorption law"
putStrLn ("τ(("++ispis x++" `OR` ("++ispis y++" `AND` "++ispis x++")) -p-> "++ispis x++")\n =τ(("
++ispis x++" `OR` "++ispiskr (y `opSa` x)++") -p-> "++ispis x++")\n =τ("
++ispiskr (x `opPa` (y `opSa` x))++") -p-> "++ispis x++")\n =τ("
++ispiskr ((x `opPa` (y `opSa` x)) `pimpa` x)++")\n ="
++[particija abc ((x `opPa` (y `opSa` x)) `pimpa` x)])
-- /show
-- show 9. Dual absorption law
putStrLn ("τ(("++ispis x++" `AND` ("++ispis y++" `OR` "++ispis x++")) -s-> "++ispis x++")\n =τ(("
++ispis x++" `AND` "++ispiskr (y `opPa` x)++") -s-> "++ispis x++")\n =τ("
++ispiskr (x `opSa` (y `opPa` x))++") -s-> "++ispis x++")\n =τ("
++ispiskr ((x `opSa` (y `opPa` x)) `simpa` x)++")\n ="
++[particija abc ((x `opSa` (y `opPa` x)) `simpa` x)])
-- /show
-- show 10. Modus ponendo ponens
putStrLn "Modus ponendo ponens"
putStrLn ("τ(("++ispis w++" `AND` ("++ispis w++" -p-> "++ispis x++")) -p-> "++ispis x++")\n =τ(("
++ispis w++" `AND` "++ispiskr (w `pimpa` x)++") -p-> "++ispis x++")\n =τ(("
++ispiskr (w `opSa` (w `pimpa` x))++") -p-> "++ispis x++")\n =τ("
++ispiskr ((w `opSa` (w `pimpa` x)) `pimpa` x)++")\n ="
++[particija abc ((w `opSa` (w `pimpa` x)) `pimpa` x)])
-- /show
-- show 11. Dual modus ponendo ponens
putStrLn "Dual modus ponendo ponens"
putStrLn ("τ(("++ispis w++" `OR` ("++ispis w++" -s-> "++ispis x++")) -s-> "++ispis x++")\n =τ(("
++ispis w++" `OR` "++ispiskr (w `simpa` x)++") -s-> "++ispis x++")\n =τ(("
++ispiskr (w `opPa` (w `simpa` x))++") -s-> "++ispis x++")\n =τ("
++ispiskr ((w `opPa` (w `simpa` x)) `simpa` x)++")\n ="
++[particija abc ((w `opPa` (w `simpa` x)) `simpa` x)])
-- /show
-- show 12. Modus tollendo tollens
putStrLn "Modus tollendo tollens"
putStrLn ("τ((¬("++ispis w++") `AND` (¬("++ispis w++") -p-> ¬("++ispis x++"))) -p-> ¬("++ispis x++"))\n =τ(("
++ispis (nega w)++" `AND` ("++ispis (nega w)++" -p-> "++ispis (nega x)++")) -p-> "++ispis (nega x)++")\n =τ(("
++ispis (nega w)++" `AND` "++ispiskr ((nega w) `pimpa` (nega x))++") -p-> "++ispis (nega x)++")\n =τ(("
++ispiskr ((nega w) `opSa` ((nega w) `pimpa` (nega x)))++") -p-> "++ispis (nega x)++")\n =τ("
++ispiskr (((nega w) `opSa` ((nega w) `pimpa` (nega x))) `pimpa` (nega x))++")\n ="
++[particija abc (((nega w) `opSa` ((nega w) `pimpa` (nega x))) `pimpa` (nega x))])
-- /show
-- show 13. Demonstratio per enumerationem
putStrLn "Demonstratio per enumerationem"
putStrLn ("τ((("++ispis z++" -p-> "++ispis x++") `AND` ("++ispis w++" -p-> "++ispis x++")) -p-> (("++ispis z++" `OR` "++ispis w++") -p-> "++ispis x++"))\n =τ(("
++ispiskr (z `pimpa` x)++" `AND` "++ispiskr (w `pimpa` x)++") -p-> ("++ispiskr (z `opPa` w)++" -p-> "++ispis x++"))\n =τ("
++ispiskr ((z `pimpa` x) `opSa` (w `pimpa` x))++" -p-> "++ispiskr ((z `opPa` w) `pimpa` x)++")\n =τ("
++ispiskr (((z `pimpa` x) `opSa` (w `pimpa` x)) `pimpa` ((z `opPa` w) `pimpa` x))++")\n ="
++[particija abc (((z `pimpa` x) `opSa` (w `pimpa` x)) `pimpa` ((z `opPa` w) `pimpa` x))])
-- /show
-- show 14. Proof by contradiction
putStrLn "Proof by contradiction"
putStrLn ("τ((("++ispis x++" -p-> "++ispis y++") `AND` ("++ispis x++" -p-> ¬("++ispis y++"))) -p-> ¬("++ispis x++"))\n =τ((("
++ispis x++" -p-> "++ispis y++") `AND` ("++ispis x++" -p-> "++ispis (nega y)++")) -p-> ¬("++ispis x++"))\n =τ(("
++ispiskr (x `pimpa` y)++") `AND` ("++ispiskr (x `pimpa` (nega y))++")) -p-> "++ispis (nega x)++")\n =τ("
++ispiskr ((x `pimpa` y) `opSa` (x `pimpa` (nega y)))++")) -p-> "++ispis (nega x)++")\n =τ("
++ispiskr (((x `pimpa` y) `opSa` (x `pimpa` (nega y))) `pimpa` (nega x))++")\n ="
++[particija abc (((x `pimpa` y) `opSa` (x `pimpa` (nega y))) `pimpa` (nega x))])
-- /showAppendix
Operator tables
{-# START_FILE Linguistic2.hs #-}
-- show
-- /show
{-# LANGUAGE UndecidableInstances, FlexibleInstances, OverlappingInstances, IncoherentInstances #-}
module Linguistic2 where
import Data.Char (chr, isLower, isUpper, ord, toLower, toUpper)
import Data.List (elemIndex, nub)
import Data.Maybe (fromJust)
-- alphabet type definition and constructors
data Slovo a = Slovo a deriving (Eq, Show)
data Abeceda a = Abeceda {unAbeceda :: [Slovo a]} deriving (Eq, Show)
type Rijec a = [Slovo a]
-- |for a list the function constructs the alphabet containing unique elements of the list
lista2abeceda :: Eq a => [a] -> Abeceda a
lista2abeceda xs=Abeceda [Slovo x|x<-nub xs]
-- |for 2 Enum types (like Char) the function constructs the alphabet from first to second one
enum2abeceda :: (Eq a, Enum a) => a -> a -> Abeceda a
enum2abeceda a z=lista2abeceda [a..z]
-- |for a list the function constructs the word containing letters in the list
lista2rijec :: (Show a,Eq a) => [a] -> Rijec a
lista2rijec xs| even (length xs)= [Slovo x|x<-xs]
| otherwise= error("The word "++show xs++" doesn't have an even number of letters.")
-- |for a word the function returns the list of letters in the word
rijec2lista :: Eq a => Rijec a -> [a]
rijec2lista xs= [x|Slovo x<-xs]
elemAbc :: Eq a => Slovo a -> Abeceda a -> Bool
elemAbc s (Abeceda a) = elem s a
elemIndexAbc :: Eq a => Slovo a -> Abeceda a -> Maybe Int
elemIndexAbc s (Abeceda a) = elemIndex s a
sup :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
sup a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) > fromJust(y `elemIndexAbc` a) = x
| otherwise = y
inf :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
inf a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) < fromJust(y `elemIndexAbc` a) = x
| otherwise = y
-- |function converting two consecutive lowercase letters to an uppercase letter
zapisu :: String->String
zapisu []=[]
zapisu [x]=[x]
zapisu (x:y:xs)|isLower x && x==y = toUpper x:zapisu xs
|otherwise=x:zapisu (y:xs)
-- |function converting uppercase letter to two consecutive lowercase letters
zapisl :: String->String
zapisl []=[]
zapisl (x:xs)|isUpper x =x':x':zapisl xs
|otherwise =x:zapisl xs
where x'=toLower x
-- string output of a word
class Show a => Ispisiv a where
ispis :: Show a => Rijec a -> String
ispis []=[]
ispis [Slovo x]=show x
ispis (Slovo x:xs)=show x++"-"++ispis xs
instance Show a => Ispisiv a
instance Ispisiv Char where
ispis=zapisu.ispis'
ispis' :: Rijec Char -> String
ispis' []=[]
ispis' [Slovo x]=[x]
ispis' (Slovo x:xs)=x:ispis' xs
-- functions returning left and right letters of a word
l :: [Slovo a] -> Slovo a
l = head
d :: [Slovo a] -> Slovo a
d = last
-- |function returning a dual of a letter in an alphabet
dual :: Eq a => Abeceda a -> Slovo a -> Slovo a
dual (Abeceda []) s = error("Nema duala - slovo nije u abecedi.")
dual (Abeceda [c]) s | s==c = c
| otherwise = error("No dual - Letter is not from the alphabet.")
dual (Abeceda cs) s | s==lijevi = desni
| s==desni = lijevi
| otherwise = dual (Abeceda (tail (init cs))) s
where lijevi= l cs
desni= d cs
-- functions returning duals of left/right letters of a word
l' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
l' a= (dual a).l
d' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
d' a= (dual a).d
ljuska :: [Slovo a]->[Slovo a]
ljuska xs=[l xs,d xs]
-- |distance between letters in an alphabet
dd :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Int
dd a x y| m==Nothing || n==Nothing = error("Cannot calculate distance. Letter is not from the alphabet.")
| otherwise = abs (fromJust m-fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
-- |word length
duljina :: Eq a => Abeceda a -> Rijec a -> Int
duljina a []=0
duljina a [c]=0
duljina a (c1:c2:cs)= - dd a c1 c2 - duljina a (c2:cs)
-- word shortening
krati1 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter word
krati1 a [p,r,s,t] | duljina a [p,r,s,t]==duljina a [p,t] = [p,t]
| otherwise = [p,r,s,t]
krati1 _ cs = cs
krati2 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter sub-word
krati2 _ [] = []
krati2 a(c:cs) | length kr==2 = kr ++ drop 3 cs
| otherwise = c : krati2 a cs
where kr = ((krati1 a).(take 4)) (c:cs)
krati :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function fully shortening a word
krati a cs | cs/=kr = krati a kr
| otherwise = cs
where kr = krati2 a cs
-- symmetries
opD :: Eq a => Abeceda a -> Rijec a -> Rijec a
opD _ []=[]
opD a (s:t:ys)=dual a s:dual a t:opD a ys
opE :: Eq a => Abeceda a -> Rijec a -> Rijec a
opE _ []=[]
opE a xs=t:s:opE a ys
where n=length xs
t=d xs
s=xs !! (n-2)
ys=take (n-2) xs
--opE a (s:t:ys)=opE a ys++[t,s] --kraće, ali nije po formuli iz teksta
opF :: Eq a => Abeceda a -> Rijec a -> Rijec a
opF a=(opD a).(opE a)
-- permutations
opI :: Eq a => Abeceda a -> Rijec a -> Rijec a
opI a xs=l xs:xs++[d xs]
-- |negation operator
opK :: Eq a => Abeceda a -> Rijec a -> Rijec a
opK a xs=l' a xs:xs++[d' a xs]
opG :: Eq a => Abeceda a -> Rijec a -> Rijec a
opG a xs=d xs:xs++[l xs]
opH :: Eq a => Abeceda a -> Rijec a -> Rijec a
opH a xs=d' a xs:xs++[l' a xs]
-- serial and parallel conjecture operators
opS :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opS a xs ys = inf a (l xs) (l ys) : inf a (l xs) (l ys) : xs ++
[sup a (d xs) (l ys),inf a (d xs) (l ys)] ++ ys ++
[sup a (d xs) (d ys),sup a (d xs) (d ys)]
opP :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opP a xs ys = sup a (l xs) (l ys) : sup a (l xs) (l ys) : xs ++
[inf a (d xs) (l ys),sup a (d xs) (l ys)] ++ ys ++
[inf a (d xs) (d ys),inf a (d xs) (d ys)]
-- |partitions
particija :: Eq a => Abeceda a -> Rijec a -> Char
particija a xs | lijevi>=*lijevi' && desni<=*desni' && lijevi>*desni ='T'
| lijevi<=*lijevi' && desni<=*desni' && not (lijevi==lijevi' || desni==desni') ='A'
| lijevi==lijevi' && desni==desni' ='0'
| lijevi>=*lijevi' && desni>=*desni' && not (lijevi==lijevi' || desni==desni') ='Z'
| lijevi<=*lijevi' && desni>=*desni' && lijevi<*desni ='F'
where lijevi=l xs
desni=d xs
lijevi'=l' a xs
desni'=d' a xs
x >* y| m==Nothing || n==Nothing =error("Letter not in alphabet.")
| otherwise = (fromJust m) > (fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
x >=* y = x >* y || x==y
x <* y = not (x >=* y)
x <=* y = not (x >* y)
-- implications
pimp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pimp a x y=(opK a x) `opP'` y
where opP'=opP a
simp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
simp a x y=(opK a x) `opS'` y
where opS'=opS a
-- equivalencies
pekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pekv a x y=(x `pimp'` y) `opS'` (y `pimp'` x)
where opS'=opS a
pimp'=pimp a
sekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
sekv a x y=(x `simp'` y) `opP'` (y `simp'` x)
where opP'=opP a
simp'=simp a
-- |tautologies and rules
taut :: Eq a => Abeceda a -> Rijec a ->Rijec a -> Rijec a -> [(String,Char)]
taut a x y z= zip
["1.ZAKON ISKLJUCENJA TRECEG",
"2.DUAL ZAKONA ISKLJUCENJA TRECEG",
"3.TRANZITIVNOST IMPLIKACIJE",
"4.DUAL TRANZITIVNOSTI IMPLIKACIJE",
"5.ZAKON DVOSTRUKE NEGACIJE",
"6.ZAKON KONTRAPOZICIJE",
"7.DUAL ZAKONA KONTRAPOZICIJE",
"8.ZAKON APSORPCIJE ILI UPIJANJA",
"9.DUAL ZAKONA APSORPCIJE ILI UPIJANJA",
"10.MODUS PONENDO PONENS",
"11.DUAL MODUSA PONENDO PONENS",
"12.MODUS TOLENDO TOLLENS",
"13.DOKAZ NABRAJANJEM",
"14.DOVODJENJE DO PROTURJECJA"]
(map (particija a) [
x `opP'` (neg x),
x `opS'` (neg x),
((x `pimp'` y) `opS'` (y `pimp'` z)) `pimp'` (x `pimp'` z),
((x `simp'` y) `opP'` (y `simp'` z)) `simp'` (x `simp'` z),
(neg (neg x)) `pekv'` x,
(x `pimp'` y) `pimp'` ((neg y) `pimp'` (neg x)),
(x `simp'` y) `simp'` ((neg y) `simp'` (neg x)),
(x `opP'` (y `opP'` x)) `pimp'` x,
(x `opS'` (y `opS'` x)) `simp'` x,
(x `opS'` (x `pimp'` y)) `pimp'` y,
(x `opP'` (x `simp'` y)) `simp'` y,
((neg x) `opS'` ((neg x) `pimp'` (neg y))) `pimp'` (neg y),
((x `pimp'` z) `opS'` (y `pimp'` z)) `pimp'` ((x `opP'` y) `pimp'` z),
((x `pimp'` y) `opS'` (x `pimp'` (neg y))) `pimp'` (neg x)
]
)
where opP'=opP a
opS'=opS a
pimp'=pimp a
simp'=simp a
pekv'=pekv a
sekv'=sekv a
neg=opK a
{-# START_FILE Main.hs #-}
{-# LANGUAGE UndecidableInstances, FlexibleInstances, OverlappingInstances, IncoherentInstances #-}
module Main where
import Linguistic2
main :: IO ()
-- show Set alphabet, row and column headers and the binary operator for the table.
main=do let {abc = lista2abeceda ['a'..'c']; -- <-- CHANGE
red = map lista2rijec ["aa","bb","cc"]; -- <-- CHANGE
stupac = map lista2rijec ["aa","bb","cc"]; -- <-- CHANGE
opName = "OP";
operator = (\a x y->let opDa=opD a; opEa=opE a; opFa=opF a; neg=opK a; opPa=opP a; opSa=opS a; pimpa=pimp a; simpa=simp a; pekva=pekv a; sekva=sekv a; in
((x `opSa` y) `simpa` y) -- <-- CHANGE
);}
-- /show
-- show Formatting (latex -> regular table or LaTeX; printShell -> show just shell or the whole result)
let {latex=False; -- <-- CHANGE
printShell=True;} -- <-- CHANGE
-- /show
let {operator'=(if printShell then (opLjuska operator) else operator);
n=length stupac;
prije=(if latex then "\\begin{tabular}{|c|"++replicate n 'c'++"|}\n\\hline\n" else "");
sep=(if latex then "& " else " ");
sepRed=(if latex then "\\hline\n" else (replicate ((n+1)*11) '-'++"\n"));
eol=(if latex then "\\\\\n" else "\n");
poslije=(if latex then "\\hline\n\\end{tabular}" else "");
tablica=[(zapisl.ispis) x:[(zapisl.ispis.(krati abc)) (operator' abc x y)|y<-stupac]|x<-red];
ispisKraj=prije++redIspis (sep,eol) (opName:(map (zapisl.ispis) stupac))++sepRed++concat [redIspis (sep,eol) x|x<-tablica]++poslije;
}
putStrLn ispisKraj
opLjuska op=(\a x y->ljuska (op a x y)) -- funkcija koja na operator još primjenjuje ljusku
-- opBroj op=(fst op, (\a x y->perm2broj a (ljuska ((snd op) a x y)))) -- funkcija koja na operator još primjenjuje ljusku i zamjenjuje elemente brojevima
perm :: Abeceda a -> [Rijec a]
perm abc = [[x,y]|x<-a,y<-a]
where a=unAbeceda abc
perm' :: Abeceda a -> [Rijec a]
perm' abc = [[x,y]|x<-reverse a,y<-a]
where a=unAbeceda abc
-- perm2broj :: Eq a => Abeceda a->Rijec a->String
-- perm2broj a xs=head [c|(b,c)<-zip (perm a) [show n|n<-[1..]],b==xs]
-- |for a given separator, end of line string and list returns a line string
redIspis::(String,String)->[String]->String
redIspis (_,eol) [xs]=make10 xs++eol
redIspis (sep,eol) (xs:xss)=make10 xs ++ sep ++ redIspis (sep,eol) xss
make10::String->String
make10 xs| n<10 =xs++replicate (10-n) ' '
| otherwise =xs
where n=length xsExample
This example shows partitions of a 2-generator alphabet and truth tables for the set operator
{-# START_FILE Linguistic2.hs #-}
-- show
-- /show
{-# LANGUAGE UndecidableInstances, FlexibleInstances, OverlappingInstances, IncoherentInstances #-}
module Linguistic2 where
import Data.Char (chr, isLower, isUpper, ord, toLower, toUpper)
import Data.List (elemIndex, nub)
import Data.Maybe (fromJust)
-- alphabet type definition and constructors
data Slovo a = Slovo a deriving (Eq, Show)
data Abeceda a = Abeceda {unAbeceda :: [Slovo a]} deriving (Eq, Show)
type Rijec a = [Slovo a]
-- |for a list the function constructs the alphabet containing unique elements of the list
lista2abeceda :: Eq a => [a] -> Abeceda a
lista2abeceda xs=Abeceda [Slovo x|x<-nub xs]
-- |for 2 Enum types (like Char) the function constructs the alphabet from first to second one
enum2abeceda :: (Eq a, Enum a) => a -> a -> Abeceda a
enum2abeceda a z=lista2abeceda [a..z]
-- |for a list the function constructs the word containing letters in the list
lista2rijec :: (Show a,Eq a) => [a] -> Rijec a
lista2rijec xs| even (length xs)= [Slovo x|x<-xs]
| otherwise= error("The word "++show xs++" doesn't have an even number of letters.")
-- |for a word the function returns the list of letters in the word
rijec2lista :: Eq a => Rijec a -> [a]
rijec2lista xs= [x|Slovo x<-xs]
elemAbc :: Eq a => Slovo a -> Abeceda a -> Bool
elemAbc s (Abeceda a) = elem s a
elemIndexAbc :: Eq a => Slovo a -> Abeceda a -> Maybe Int
elemIndexAbc s (Abeceda a) = elemIndex s a
sup :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
sup a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) > fromJust(y `elemIndexAbc` a) = x
| otherwise = y
inf :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
inf a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) < fromJust(y `elemIndexAbc` a) = x
| otherwise = y
-- |function converting two consecutive lowercase letters to an uppercase letter
zapisu :: String->String
zapisu []=[]
zapisu [x]=[x]
zapisu (x:y:xs)|isLower x && x==y = toUpper x:zapisu xs
|otherwise=x:zapisu (y:xs)
-- |function converting uppercase letter to two consecutive lowercase letters
zapisl :: String->String
zapisl []=[]
zapisl (x:xs)|isUpper x =x':x':zapisl xs
|otherwise =x:zapisl xs
where x'=toLower x
-- string output of a word
class Show a => Ispisiv a where
ispis :: Show a => Rijec a -> String
ispis []=[]
ispis [Slovo x]=show x
ispis (Slovo x:xs)=show x++"-"++ispis xs
instance Show a => Ispisiv a
instance Ispisiv Char where
ispis=zapisu.ispis'
ispis' :: Rijec Char -> String
ispis' []=[]
ispis' [Slovo x]=[x]
ispis' (Slovo x:xs)=x:ispis' xs
-- functions returning left and right letters of a word
l :: [Slovo a] -> Slovo a
l = head
d :: [Slovo a] -> Slovo a
d = last
-- |function returning a dual of a letter in an alphabet
dual :: Eq a => Abeceda a -> Slovo a -> Slovo a
dual (Abeceda []) s = error("Nema duala - slovo nije u abecedi.")
dual (Abeceda [c]) s | s==c = c
| otherwise = error("No dual - Letter is not from the alphabet.")
dual (Abeceda cs) s | s==lijevi = desni
| s==desni = lijevi
| otherwise = dual (Abeceda (tail (init cs))) s
where lijevi= l cs
desni= d cs
-- functions returning duals of left/right letters of a word
l' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
l' a= (dual a).l
d' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
d' a= (dual a).d
ljuska :: [Slovo a]->[Slovo a]
ljuska xs=[l xs,d xs]
-- |distance between letters in an alphabet
dd :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Int
dd a x y| m==Nothing || n==Nothing = error("Cannot calculate distance. Letter is not from the alphabet.")
| otherwise = abs (fromJust m-fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
-- |word length
duljina :: Eq a => Abeceda a -> Rijec a -> Int
duljina a []=0
duljina a [c]=0
duljina a (c1:c2:cs)= - dd a c1 c2 - duljina a (c2:cs)
-- word shortening
krati1 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter word
krati1 a [p,r,s,t] | duljina a [p,r,s,t]==duljina a [p,t] = [p,t]
| otherwise = [p,r,s,t]
krati1 _ cs = cs
krati2 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter sub-word
krati2 _ [] = []
krati2 a(c:cs) | length kr==2 = kr ++ drop 3 cs
| otherwise = c : krati2 a cs
where kr = ((krati1 a).(take 4)) (c:cs)
krati :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function fully shortening a word
krati a cs | cs/=kr = krati a kr
| otherwise = cs
where kr = krati2 a cs
-- symmetries
opD :: Eq a => Abeceda a -> Rijec a -> Rijec a
opD _ []=[]
opD a (s:t:ys)=dual a s:dual a t:opD a ys
opE :: Eq a => Abeceda a -> Rijec a -> Rijec a
opE _ []=[]
opE a xs=t:s:opE a ys
where n=length xs
t=d xs
s=xs !! (n-2)
ys=take (n-2) xs
--opE a (s:t:ys)=opE a ys++[t,s] --kraće, ali nije po formuli iz teksta
opF :: Eq a => Abeceda a -> Rijec a -> Rijec a
opF a=(opD a).(opE a)
-- permutations
opI :: Eq a => Abeceda a -> Rijec a -> Rijec a
opI a xs=l xs:xs++[d xs]
-- |negation operator
opK :: Eq a => Abeceda a -> Rijec a -> Rijec a
opK a xs=l' a xs:xs++[d' a xs]
opG :: Eq a => Abeceda a -> Rijec a -> Rijec a
opG a xs=d xs:xs++[l xs]
opH :: Eq a => Abeceda a -> Rijec a -> Rijec a
opH a xs=d' a xs:xs++[l' a xs]
-- serial and parallel conjecture operators
opS :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opS a xs ys = inf a (l xs) (l ys) : inf a (l xs) (l ys) : xs ++
[sup a (d xs) (l ys),inf a (d xs) (l ys)] ++ ys ++
[sup a (d xs) (d ys),sup a (d xs) (d ys)]
opP :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opP a xs ys = sup a (l xs) (l ys) : sup a (l xs) (l ys) : xs ++
[inf a (d xs) (l ys),sup a (d xs) (l ys)] ++ ys ++
[inf a (d xs) (d ys),inf a (d xs) (d ys)]
-- |partitions
particija :: Eq a => Abeceda a -> Rijec a -> Char
particija a xs | lijevi>=*lijevi' && desni<=*desni' && lijevi>*desni ='T'
| lijevi<=*lijevi' && desni<=*desni' && not (lijevi==lijevi' || desni==desni') ='A'
| lijevi==lijevi' && desni==desni' ='0'
| lijevi>=*lijevi' && desni>=*desni' && not (lijevi==lijevi' || desni==desni') ='Z'
| lijevi<=*lijevi' && desni>=*desni' && lijevi<*desni ='F'
where lijevi=l xs
desni=d xs
lijevi'=l' a xs
desni'=d' a xs
x >* y| m==Nothing || n==Nothing =error("Letter not in alphabet.")
| otherwise = (fromJust m) > (fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
x >=* y = x >* y || x==y
x <* y = not (x >=* y)
x <=* y = not (x >* y)
-- implications
pimp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pimp a x y=(opK a x) `opP'` y
where opP'=opP a
simp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
simp a x y=(opK a x) `opS'` y
where opS'=opS a
-- equivalencies
pekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pekv a x y=(x `pimp'` y) `opS'` (y `pimp'` x)
where opS'=opS a
pimp'=pimp a
sekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
sekv a x y=(x `simp'` y) `opP'` (y `simp'` x)
where opP'=opP a
simp'=simp a
-- |tautologies and rules
taut :: Eq a => Abeceda a -> Rijec a ->Rijec a -> Rijec a -> [(String,Char)]
taut a x y z= zip
["1.ZAKON ISKLJUCENJA TRECEG",
"2.DUAL ZAKONA ISKLJUCENJA TRECEG",
"3.TRANZITIVNOST IMPLIKACIJE",
"4.DUAL TRANZITIVNOSTI IMPLIKACIJE",
"5.ZAKON DVOSTRUKE NEGACIJE",
"6.ZAKON KONTRAPOZICIJE",
"7.DUAL ZAKONA KONTRAPOZICIJE",
"8.ZAKON APSORPCIJE ILI UPIJANJA",
"9.DUAL ZAKONA APSORPCIJE ILI UPIJANJA",
"10.MODUS PONENDO PONENS",
"11.DUAL MODUSA PONENDO PONENS",
"12.MODUS TOLENDO TOLLENS",
"13.DOKAZ NABRAJANJEM",
"14.DOVODJENJE DO PROTURJECJA"]
(map (particija a) [
x `opP'` (neg x),
x `opS'` (neg x),
((x `pimp'` y) `opS'` (y `pimp'` z)) `pimp'` (x `pimp'` z),
((x `simp'` y) `opP'` (y `simp'` z)) `simp'` (x `simp'` z),
(neg (neg x)) `pekv'` x,
(x `pimp'` y) `pimp'` ((neg y) `pimp'` (neg x)),
(x `simp'` y) `simp'` ((neg y) `simp'` (neg x)),
(x `opP'` (y `opP'` x)) `pimp'` x,
(x `opS'` (y `opS'` x)) `simp'` x,
(x `opS'` (x `pimp'` y)) `pimp'` y,
(x `opP'` (x `simp'` y)) `simp'` y,
((neg x) `opS'` ((neg x) `pimp'` (neg y))) `pimp'` (neg y),
((x `pimp'` z) `opS'` (y `pimp'` z)) `pimp'` ((x `opP'` y) `pimp'` z),
((x `pimp'` y) `opS'` (x `pimp'` (neg y))) `pimp'` (neg x)
]
)
where opP'=opP a
opS'=opS a
pimp'=pimp a
simp'=simp a
pekv'=pekv a
sekv'=sekv a
neg=opK a
{-# START_FILE Main.hs #-}
{-# LANGUAGE UndecidableInstances, FlexibleInstances, OverlappingInstances, IncoherentInstances #-}
module Main where
import Linguistic2
main :: IO ()
-- show Set alphabet, row and column headers and the binary operator for the table.
main=do let {abc = lista2abeceda ['a'..'b']; -- <-- CHANGE
red = [map lista2rijec x| x<-[["ba"],["aa","bb"],["ab"]]]; -- <-- CHANGE
stupac = red; -- <-- CHANGE
opName = "AND";
operator = (\a x y->let opDa=opD a; opEa=opE a; opFa=opF a; neg=opK a; opPa=opP a; opSa=opS a; pimpa=pimp a; simpa=simp a; pekva=pekv a; sekva=sekv a; in
(x `opSa` y) -- <-- CHANGE
);}
-- /show
-- show Formatting (latex -> regular table or LaTeX; printShell -> show just shell or the whole result)
let {latex=False; -- <-- CHANGE
printShell=True; -- <-- CHANGE
printPartition=False;} -- <-- CHANGE
-- /show
let {tab=[([x,y],particija abc [x,y])|x <- unAbeceda abc,y <- unAbeceda abc];
operator'=(if printShell then (opLjuska operator) else operator);
n=length (concat stupac);
prije=(if latex then "%% requires 'tabu' package\n\\begin{tabu}{c|"++concatWith "|[on 2pt off 2pt]" [replicate (length ygr) 'l'|ygr<-stupac]++"}\n" else "");
sepCol=(if latex then "& " else " ");
sepColGr=(if latex then "& " else "| ");
eol=(if latex then "\\\\\n" else "\n");
sepHeadRow=(if latex then "\\tabucline{-}\n" else (replicate ((n+1)*11) '-'++"\n"));
sepRowGr=(if latex then "\\tabucline[on 2pt off 2pt]{-}\n" else (replicate ((n+1)*11) '-'++"\n"));
poslije=(if latex then "\\end{tabu}" else "");
printPartFunc a x=(if printPartition then (":"++[particija a x]) else "");
tablica=[[[(zapisl.ispis) x++(printPartFunc abc x)]:[[(zapisl.ispis.(krati abc)) (operator' abc x y)++(printPartFunc abc (operator' abc x y))|y<-ygr]|ygr<-stupac]|x<-xgr]|xgr<-red];
ispisKraj=prije++redIspis (sepCol,sepColGr,eol) ([opName]:[map (\x->(zapisl.ispis) x++(printPartFunc abc x)) ygr|ygr<-stupac])++sepHeadRow++concatWith sepRowGr [concat [redIspis (sepCol,sepColGr,eol) x|x<-xgr]|xgr<-tablica]++poslije;
--ispisKraj=prije++redIspis (sepCol,eol) (opName:(map (\x->(zapisl.ispis) x++(printPartFunc abc x)) (concat stupac)))++sepHeadRow++concat [redIspis (sepCol,eol) x|x<-tablica]++poslije;
}
putStrLn (filter (/='"') (concat [p:": "++show [ispis x|(x,y)<-tab,y==p]++"\n"|p<-['T','A','0','Z','F']]))
putStrLn ispisKraj
opLjuska op=(\a x y->ljuska (op a x y)) -- funkcija koja na operator još primjenjuje ljusku
-- opBroj op=(fst op, (\a x y->perm2broj a (ljuska ((snd op) a x y)))) -- funkcija koja na operator još primjenjuje ljusku i zamjenjuje elemente brojevima
perm :: Abeceda a -> [Rijec a]
perm abc = [[x,y]|x<-a,y<-a]
where a=unAbeceda abc
perm' :: Abeceda a -> [Rijec a]
perm' abc = [[x,y]|x<-reverse a,y<-a]
where a=unAbeceda abc
-- perm2broj :: Eq a => Abeceda a->Rijec a->String
-- perm2broj a xs=head [c|(b,c)<-zip (perm a) [show n|n<-[1..]],b==xs]
-- |for a given separator, end of line string and list returns a line string
redIspis::(String,String,String)->[[String]]->String
redIspis (sepCol,_,eol) [xss]=concatWith sepCol [make10 xs|xs<-xss]++eol
redIspis (sepCol,sepColGr,eol) (xss:xsss)=(concatWith sepCol [make10 xs|xs<-xss]) ++ sepColGr ++ redIspis (sepCol,sepColGr,eol) xsss
concatWith::String->[String]->String
concatWith _ [x]=x
concatWith s (x:xs)=x++s++concatWith s xs
make10::String->String
make10 xs| n<10 =xs++replicate (10-n) ' '
| otherwise =xs
where n=length xsInteger type example
{-# START_FILE Linguistic2.hs #-}
-- show
-- /show
{-# LANGUAGE UndecidableInstances, FlexibleInstances, OverlappingInstances, IncoherentInstances #-}
module Linguistic2 where
import Data.Char (chr, isLower, isUpper, ord, toLower, toUpper)
import Data.List (elemIndex, nub)
import Data.Maybe (fromJust)
-- alphabet type definition and constructors
data Slovo a = Slovo a deriving (Eq, Show)
data Abeceda a = Abeceda {unAbeceda :: [Slovo a]} deriving (Eq, Show)
type Rijec a = [Slovo a]
-- |for a list the function constructs the alphabet containing unique elements of the list
lista2abeceda :: Eq a => [a] -> Abeceda a
lista2abeceda xs=Abeceda [Slovo x|x<-nub xs]
-- |for 2 Enum types (like Char) the function constructs the alphabet from first to second one
enum2abeceda :: (Eq a, Enum a) => a -> a -> Abeceda a
enum2abeceda a z=lista2abeceda [a..z]
-- |for a list the function constructs the word containing letters in the list
lista2rijec :: (Show a,Eq a) => [a] -> Rijec a
lista2rijec xs| even (length xs)= [Slovo x|x<-xs]
| otherwise= error("The word "++show xs++" doesn't have an even number of letters.")
-- |for a word the function returns the list of letters in the word
rijec2lista :: Eq a => Rijec a -> [a]
rijec2lista xs= [x|Slovo x<-xs]
elemAbc :: Eq a => Slovo a -> Abeceda a -> Bool
elemAbc s (Abeceda a) = elem s a
elemIndexAbc :: Eq a => Slovo a -> Abeceda a -> Maybe Int
elemIndexAbc s (Abeceda a) = elemIndex s a
sup :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
sup a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) > fromJust(y `elemIndexAbc` a) = x
| otherwise = y
inf :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
inf a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) < fromJust(y `elemIndexAbc` a) = x
| otherwise = y
-- |function converting two consecutive lowercase letters to an uppercase letter
zapisu :: String->String
zapisu []=[]
zapisu [x]=[x]
zapisu (x:y:xs)|isLower x && x==y = toUpper x:zapisu xs
|otherwise=x:zapisu (y:xs)
-- |function converting uppercase letter to two consecutive lowercase letters
zapisl :: String->String
zapisl []=[]
zapisl (x:xs)|isUpper x =x':x':zapisl xs
|otherwise =x:zapisl xs
where x'=toLower x
-- string output of a word
class Show a => Ispisiv a where
ispis :: Show a => Rijec a -> String
ispis []=[]
ispis [Slovo x]=show x
ispis (Slovo x:xs)=show x++"-"++ispis xs
instance Show a => Ispisiv a
instance Ispisiv Char where
ispis=zapisu.ispis'
ispis' :: Rijec Char -> String
ispis' []=[]
ispis' [Slovo x]=[x]
ispis' (Slovo x:xs)=x:ispis' xs
-- functions returning left and right letters of a word
l :: [Slovo a] -> Slovo a
l = head
d :: [Slovo a] -> Slovo a
d = last
-- |function returning a dual of a letter in an alphabet
dual :: Eq a => Abeceda a -> Slovo a -> Slovo a
dual (Abeceda []) s = error("Nema duala - slovo nije u abecedi.")
dual (Abeceda [c]) s | s==c = c
| otherwise = error("No dual - Letter is not from the alphabet.")
dual (Abeceda cs) s | s==lijevi = desni
| s==desni = lijevi
| otherwise = dual (Abeceda (tail (init cs))) s
where lijevi= l cs
desni= d cs
-- functions returning duals of left/right letters of a word
l' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
l' a= (dual a).l
d' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
d' a= (dual a).d
ljuska :: [Slovo a]->[Slovo a]
ljuska xs=[l xs,d xs]
-- |distance between letters in an alphabet
dd :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Int
dd a x y| m==Nothing || n==Nothing = error("Cannot calculate distance. Letter is not from the alphabet.")
| otherwise = abs (fromJust m-fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
-- |word length
duljina :: Eq a => Abeceda a -> Rijec a -> Int
duljina a []=0
duljina a [c]=0
duljina a (c1:c2:cs)= - dd a c1 c2 - duljina a (c2:cs)
-- word shortening
krati1 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter word
krati1 a [p,r,s,t] | duljina a [p,r,s,t]==duljina a [p,t] = [p,t]
| otherwise = [p,r,s,t]
krati1 _ cs = cs
krati2 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter sub-word
krati2 _ [] = []
krati2 a(c:cs) | length kr==2 = kr ++ drop 3 cs
| otherwise = c : krati2 a cs
where kr = ((krati1 a).(take 4)) (c:cs)
krati :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function fully shortening a word
krati a cs | cs/=kr = krati a kr
| otherwise = cs
where kr = krati2 a cs
-- symmetries
opD :: Eq a => Abeceda a -> Rijec a -> Rijec a
opD _ []=[]
opD a (s:t:ys)=dual a s:dual a t:opD a ys
opE :: Eq a => Abeceda a -> Rijec a -> Rijec a
opE _ []=[]
opE a xs=t:s:opE a ys
where n=length xs
t=d xs
s=xs !! (n-2)
ys=take (n-2) xs
--opE a (s:t:ys)=opE a ys++[t,s] --kraće, ali nije po formuli iz teksta
opF :: Eq a => Abeceda a -> Rijec a -> Rijec a
opF a=(opD a).(opE a)
-- permutations
opI :: Eq a => Abeceda a -> Rijec a -> Rijec a
opI a xs=l xs:xs++[d xs]
-- |negation operator
opK :: Eq a => Abeceda a -> Rijec a -> Rijec a
opK a xs=l' a xs:xs++[d' a xs]
opG :: Eq a => Abeceda a -> Rijec a -> Rijec a
opG a xs=d xs:xs++[l xs]
opH :: Eq a => Abeceda a -> Rijec a -> Rijec a
opH a xs=d' a xs:xs++[l' a xs]
-- serial and parallel conjecture operators
opS :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opS a xs ys = inf a (l xs) (l ys) : inf a (l xs) (l ys) : xs ++
[sup a (d xs) (l ys),inf a (d xs) (l ys)] ++ ys ++
[sup a (d xs) (d ys),sup a (d xs) (d ys)]
opP :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opP a xs ys = sup a (l xs) (l ys) : sup a (l xs) (l ys) : xs ++
[inf a (d xs) (l ys),sup a (d xs) (l ys)] ++ ys ++
[inf a (d xs) (d ys),inf a (d xs) (d ys)]
-- |partitions
particija :: Eq a => Abeceda a -> Rijec a -> Char
particija a xs | lijevi>=*lijevi' && desni<=*desni' && lijevi>*desni ='T'
| lijevi<=*lijevi' && desni<=*desni' && not (lijevi==lijevi' || desni==desni') ='A'
| lijevi==lijevi' && desni==desni' ='0'
| lijevi>=*lijevi' && desni>=*desni' && not (lijevi==lijevi' || desni==desni') ='Z'
| lijevi<=*lijevi' && desni>=*desni' && lijevi<*desni ='F'
where lijevi=l xs
desni=d xs
lijevi'=l' a xs
desni'=d' a xs
x >* y| m==Nothing || n==Nothing =error("Letter not in alphabet.")
| otherwise = (fromJust m) > (fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
x >=* y = x >* y || x==y
x <* y = not (x >=* y)
x <=* y = not (x >* y)
-- implications
pimp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pimp a x y=(opK a x) `opP'` y
where opP'=opP a
simp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
simp a x y=(opK a x) `opS'` y
where opS'=opS a
-- equivalencies
pekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pekv a x y=(x `pimp'` y) `opS'` (y `pimp'` x)
where opS'=opS a
pimp'=pimp a
sekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
sekv a x y=(x `simp'` y) `opP'` (y `simp'` x)
where opP'=opP a
simp'=simp a
-- |tautologies and rules
taut :: Eq a => Abeceda a -> Rijec a ->Rijec a -> Rijec a -> [(String,Char)]
taut a x y z= zip
["1.ZAKON ISKLJUCENJA TRECEG",
"2.DUAL ZAKONA ISKLJUCENJA TRECEG",
"3.TRANZITIVNOST IMPLIKACIJE",
"4.DUAL TRANZITIVNOSTI IMPLIKACIJE",
"5.ZAKON DVOSTRUKE NEGACIJE",
"6.ZAKON KONTRAPOZICIJE",
"7.DUAL ZAKONA KONTRAPOZICIJE",
"8.ZAKON APSORPCIJE ILI UPIJANJA",
"9.DUAL ZAKONA APSORPCIJE ILI UPIJANJA",
"10.MODUS PONENDO PONENS",
"11.DUAL MODUSA PONENDO PONENS",
"12.MODUS TOLENDO TOLLENS",
"13.DOKAZ NABRAJANJEM",
"14.DOVODJENJE DO PROTURJECJA"]
(map (particija a) [
x `opP'` (neg x),
x `opS'` (neg x),
((x `pimp'` y) `opS'` (y `pimp'` z)) `pimp'` (x `pimp'` z),
((x `simp'` y) `opP'` (y `simp'` z)) `simp'` (x `simp'` z),
(neg (neg x)) `pekv'` x,
(x `pimp'` y) `pimp'` ((neg y) `pimp'` (neg x)),
(x `simp'` y) `simp'` ((neg y) `simp'` (neg x)),
(x `opP'` (y `opP'` x)) `pimp'` x,
(x `opS'` (y `opS'` x)) `simp'` x,
(x `opS'` (x `pimp'` y)) `pimp'` y,
(x `opP'` (x `simp'` y)) `simp'` y,
((neg x) `opS'` ((neg x) `pimp'` (neg y))) `pimp'` (neg y),
((x `pimp'` z) `opS'` (y `pimp'` z)) `pimp'` ((x `opP'` y) `pimp'` z),
((x `pimp'` y) `opS'` (x `pimp'` (neg y))) `pimp'` (neg x)
]
)
where opP'=opP a
opS'=opS a
pimp'=pimp a
simp'=simp a
pekv'=pekv a
sekv'=sekv a
neg=opK a
{-# START_FILE Main.hs #-}
{-# LANGUAGE UndecidableInstances, FlexibleInstances, OverlappingInstances, IncoherentInstances #-}
module Main where
import Linguistic2
main :: IO ()
-- show Set alphabet, row and column headers and the binary operator for the table.
main=do let {abc = lista2abeceda ([1..2]::[Int]); -- <-- CHANGE
red = [map lista2rijec x| x<-([[[2,1],[2,2]],[[1,1],[1,2]]]::[[[Int]]])]; -- <-- CHANGE
stupac = [map lista2rijec x| x<-([[[2,1],[2,2]],[[1,1],[1,2]]]::[[[Int]]])]; -- <-- CHANGE
opName = "OR";
operator = (\a x y->let opDa=opD a; opEa=opE a; opFa=opF a; neg=opK a; opPa=opP a; opSa=opS a; pimpa=pimp a; simpa=simp a; pekva=pekv a; sekva=sekv a; in
(x `opPa` y) -- <-- CHANGE
);}
-- /show
-- show Formatting (latex -> regular table or LaTeX; printShell -> show just shell or the whole result)
let {latex=False; -- <-- CHANGE
printShell=True; -- <-- CHANGE
printPartition=False;} -- <-- CHANGE
-- /show
let {tab=[([x,y],particija abc [x,y])|x <- unAbeceda abc,y <- unAbeceda abc];
operator'=(if printShell then (opLjuska operator) else operator);
n=length (concat stupac);
prije=(if latex then "%% requires 'tabu' package\n\\begin{tabu}{c|"++concatWith "|[on 2pt off 2pt]" [replicate (length ygr) 'l'|ygr<-stupac]++"}\n" else "");
sepCol=(if latex then "& " else " ");
sepColGr=(if latex then "& " else "| ");
eol=(if latex then "\\\\\n" else "\n");
sepHeadRow=(if latex then "\\tabucline{-}\n" else (replicate ((n+1)*11) '-'++"\n"));
sepRowGr=(if latex then "\\tabucline[on 2pt off 2pt]{-}\n" else (replicate ((n+1)*11) '-'++"\n"));
poslije=(if latex then "\\end{tabu}" else "");
printPartFunc a x=(if printPartition then (":"++[particija a x]) else "");
tablica=[[[(zapisl.ispis) x++(printPartFunc abc x)]:[[(zapisl.ispis.(krati abc)) (operator' abc x y)++(printPartFunc abc (operator' abc x y))|y<-ygr]|ygr<-stupac]|x<-xgr]|xgr<-red];
ispisKraj=prije++redIspis (sepCol,sepColGr,eol) ([opName]:[map (\x->(zapisl.ispis) x++(printPartFunc abc x)) ygr|ygr<-stupac])++sepHeadRow++concatWith sepRowGr [concat [redIspis (sepCol,sepColGr,eol) x|x<-xgr]|xgr<-tablica]++poslije;
--ispisKraj=prije++redIspis (sepCol,eol) (opName:(map (\x->(zapisl.ispis) x++(printPartFunc abc x)) (concat stupac)))++sepHeadRow++concat [redIspis (sepCol,eol) x|x<-tablica]++poslije;
}
putStrLn (filter (/='"') (concat [p:": "++show [ispis x|(x,y)<-tab,y==p]++"\n"|p<-['T','A','0','Z','F']]))
putStrLn ispisKraj
opLjuska op=(\a x y->ljuska (op a x y)) -- funkcija koja na operator još primjenjuje ljusku
-- opBroj op=(fst op, (\a x y->perm2broj a (ljuska ((snd op) a x y)))) -- funkcija koja na operator još primjenjuje ljusku i zamjenjuje elemente brojevima
perm :: Abeceda a -> [Rijec a]
perm abc = [[x,y]|x<-a,y<-a]
where a=unAbeceda abc
perm' :: Abeceda a -> [Rijec a]
perm' abc = [[x,y]|x<-reverse a,y<-a]
where a=unAbeceda abc
-- perm2broj :: Eq a => Abeceda a->Rijec a->String
-- perm2broj a xs=head [c|(b,c)<-zip (perm a) [show n|n<-[1..]],b==xs]
-- |for a given separator, end of line string and list returns a line string
redIspis::(String,String,String)->[[String]]->String
redIspis (sepCol,_,eol) [xss]=concatWith sepCol [make10 xs|xs<-xss]++eol
redIspis (sepCol,sepColGr,eol) (xss:xsss)=(concatWith sepCol [make10 xs|xs<-xss]) ++ sepColGr ++ redIspis (sepCol,sepColGr,eol) xsss
concatWith::String->[String]->String
concatWith _ [x]=x
concatWith s (x:xs)=x++s++concatWith s xs
make10::String->String
make10 xs| n<10 =xs++replicate (10-n) ' '
| otherwise =xs
where n=length xsExpression calculator
{-# START_FILE Linguistic2.hs #-}
-- show
-- /show
{-# LANGUAGE UndecidableInstances, FlexibleInstances, OverlappingInstances, IncoherentInstances #-}
module Linguistic2 where
import Data.Char (chr, isLower, isUpper, ord, toLower, toUpper)
import Data.List (elemIndex, nub)
import Data.Maybe (fromJust)
-- alphabet type definition and constructors
data Slovo a = Slovo a deriving (Eq, Show)
data Abeceda a = Abeceda {unAbeceda :: [Slovo a]} deriving (Eq, Show)
type Rijec a = [Slovo a]
-- |for a list the function constructs the alphabet containing unique elements of the list
lista2abeceda :: Eq a => [a] -> Abeceda a
lista2abeceda xs=Abeceda [Slovo x|x<-nub xs]
-- |for 2 Enum types (like Char) the function constructs the alphabet from first to second one
enum2abeceda :: (Eq a, Enum a) => a -> a -> Abeceda a
enum2abeceda a z=lista2abeceda [a..z]
-- |for a list the function constructs the word containing letters in the list
lista2rijec :: (Show a,Eq a) => [a] -> Rijec a
lista2rijec xs| even (length xs)= [Slovo x|x<-xs]
| otherwise= error("The word "++show xs++" doesn't have an even number of letters.")
-- |for a word the function returns the list of letters in the word
rijec2lista :: Eq a => Rijec a -> [a]
rijec2lista xs= [x|Slovo x<-xs]
elemAbc :: Eq a => Slovo a -> Abeceda a -> Bool
elemAbc s (Abeceda a) = elem s a
elemIndexAbc :: Eq a => Slovo a -> Abeceda a -> Maybe Int
elemIndexAbc s (Abeceda a) = elemIndex s a
ggeq :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Bool
ggeq a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) >= fromJust(y `elemIndexAbc` a) = True
| otherwise = False
gleq :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Bool
gleq a x y| x `elemIndexAbc` a==Nothing || y `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| fromJust (x `elemIndexAbc` a) <= fromJust(y `elemIndexAbc` a) = True
| otherwise = False
geq :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Bool
geq a x y=(ggeq a x y) && (gleq a x y)
sup :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
sup a x y| ggeq a x y = x
| otherwise = y
inf :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Slovo a
inf a x y| gleq a x y = x
| otherwise = y
-- |function converting two consecutive lowercase letters to an uppercase letter
zapisu :: String->String
zapisu []=[]
zapisu [x]=[x]
zapisu (x:y:xs)|isLower x && x==y = toUpper x:zapisu xs
|otherwise=x:zapisu (y:xs)
-- |function converting uppercase letter to two consecutive lowercase letters
zapisl :: String->String
zapisl []=[]
zapisl (x:xs)|isUpper x =x':x':zapisl xs
|otherwise =x:zapisl xs
where x'=toLower x
-- string output of a word
class Show a => Ispisiv a where
ispis :: Show a => Rijec a -> String
ispis []=[]
ispis [Slovo x]=show x
ispis (Slovo x:xs)=show x++"-"++ispis xs
instance Show a => Ispisiv a
instance Ispisiv Char where
ispis=zapisu.ispis'
ispis' :: Rijec Char -> String
ispis' []=[]
ispis' [Slovo x]=[x]
ispis' (Slovo x:xs)=x:ispis' xs
-- functions returning left and right letters of a word
l :: [Slovo a] -> Slovo a
l = head
d :: [Slovo a] -> Slovo a
d = last
-- |function returning a dual of a letter in an alphabet
dual :: Eq a => Abeceda a -> Slovo a -> Slovo a
dual (Abeceda []) s = error("Nema duala - slovo nije u abecedi.")
dual (Abeceda [c]) s | s==c = c
| otherwise = error("No dual - Letter is not from the alphabet.")
dual (Abeceda cs) s | s==lijevi = desni
| s==desni = lijevi
| otherwise = dual (Abeceda (tail (init cs))) s
where lijevi= l cs
desni= d cs
-- functions returning duals of left/right letters of a word
l' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
l' a= (dual a).l
d' :: Eq a => Abeceda a -> [Slovo a] -> Slovo a
d' a= (dual a).d
ljuska :: [Slovo a]->[Slovo a]
ljuska xs=[l xs,d xs]
-- |distance between letters in an alphabet
dd :: Eq a => Abeceda a -> Slovo a -> Slovo a -> Int
dd a x y| m==Nothing || n==Nothing = error("Cannot calculate distance. Letter is not from the alphabet.")
| otherwise = abs (fromJust m-fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
-- |word length
duljina :: Eq a => Abeceda a -> Rijec a -> Int
duljina a []=0
duljina a [c]=0
duljina a (c1:c2:cs)= - dd a c1 c2 - duljina a (c2:cs)
defekt :: Eq a => Abeceda a -> Rijec a -> Int
defekt a x| (d x) `elemIndexAbc` a==Nothing || (l x) `elemIndexAbc` a==Nothing = error("Letter is not from the alphabet.")
| otherwise = fromJust ((d x) `elemIndexAbc` a) - fromJust((l x) `elemIndexAbc` a)
sDuljina :: Eq a => Abeceda a -> Rijec a -> Rational
sDuljina a x=(fromIntegral (duljina a x)-fromIntegral (defekt a x))/2
pDuljina :: Eq a => Abeceda a -> Rijec a -> Rational
pDuljina a x=(fromIntegral (duljina a x)+fromIntegral (defekt a x))/2
-- word shortening
krati1 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter word
krati1 a [p,r,s,t] | duljina a [p,r,s,t]==duljina a [p,t] = [p,t]
| otherwise = [p,r,s,t]
krati1 _ cs = cs
krati2 :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function shortening a 4 letter sub-word
krati2 _ [] = []
krati2 a(c:cs) | length kr==2 = kr ++ drop 3 cs
| otherwise = c : krati2 a cs
where kr = ((krati1 a).(take 4)) (c:cs)
krati :: Eq a => Abeceda a -> Rijec a -> Rijec a -- function fully shortening a word
krati a cs | cs/=kr = krati a kr
| otherwise = cs
where kr = krati2 a cs
oBaza :: Abeceda a -> [Rijec a]
oBaza abc = [[x,y]|x <- unAbeceda abc,y <- unAbeceda abc]
-- quasi-order
qleq :: Eq a => Abeceda a->Rijec a-> Rijec a->Bool
qleq a x y |(ggeq a (l x) (l y)) && (gleq a (d x) (d y)) = True
| otherwise = False
qgeq :: Eq a => Abeceda a->Rijec a-> Rijec a->Bool
qgeq a x y |(gleq a (l x) (l y)) && (ggeq a (d x) (d y)) = True
| otherwise = False
qeq :: Eq a => Abeceda a->Rijec a-> Rijec a->Bool
qeq a x y |(qleq a x y) && (qleq a y x) = True
| otherwise = False
sNula :: Abeceda a->Rijec a
sNula (Abeceda a)=[d a,l a]
pNula :: Abeceda a->Rijec a
pNula (Abeceda a)=[l a,d a]
-- jezgre
opJs :: Abeceda a->Rijec a->Rijec a
opJs a x=sNula a++x++sNula a
opJp :: Abeceda a->Rijec a->Rijec a
opJp a x=pNula a++x++pNula a
-- ljuske
sLjuska :: Eq a => Abeceda a->Rijec a->Rijec a
sLjuska a x=l x:(inf a (l x) (d x)):(sup a (l x) (d x)):d x:[]
pLjuska :: Eq a => Abeceda a->Rijec a->Rijec a
pLjuska a x=l x:(sup a (l x) (d x)):(inf a (l x) (d x)):d x:[]
-- operatori inverzivnosti
opIs :: Eq a => Abeceda a->Rijec a->Rijec a
opIs a x=l x:infx:infx:x++supx:infx:infx:supx:d x:[]
where infx=(inf a (l x) (d x))
supx=(sup a (l x) (d x))
opIp :: Eq a => Abeceda a->Rijec a->Rijec a
opIp a x=l x:supx:supx:x++infx:supx:supx:infx:d x:[]
where infx=(inf a (l x) (d x))
supx=(sup a (l x) (d x))
opSminus :: Eq a => Abeceda a->Rijec a->Rijec a->Rijec a
opSminus a x y=opS a x (opIs a y)
opPminus :: Eq a => Abeceda a->Rijec a->Rijec a->Rijec a
opPminus a x y=opP a x (opIp a y)
-- operatori komplementarnosti
opKs :: Eq a => Abeceda a -> Rijec a -> Rijec a
opKs (Abeceda a) xs=l a:xs++[d a]
opKp :: Eq a => Abeceda a -> Rijec a -> Rijec a
opKp (Abeceda a) xs=d a:xs++[l a]
-- symmetries
opD :: Eq a => Abeceda a -> Rijec a -> Rijec a
opD _ []=[]
opD a (s:t:ys)=dual a s:dual a t:opD a ys
opE :: Eq a => Abeceda a -> Rijec a -> Rijec a
opE _ []=[]
opE a xs=t:s:opE a ys
where n=length xs
t=d xs
s=xs !! (n-2)
ys=take (n-2) xs
--opE a (s:t:ys)=opE a ys++[t,s] --kraće, ali nije po formuli iz teksta
opF :: Eq a => Abeceda a -> Rijec a -> Rijec a
opF a=(opD a).(opE a)
-- permutations
opI :: Eq a => Abeceda a -> Rijec a -> Rijec a
opI a xs=l xs:xs++[d xs]
-- |negation operator
opK :: Eq a => Abeceda a -> Rijec a -> Rijec a
opK a xs=l' a xs:xs++[d' a xs]
opG :: Eq a => Abeceda a -> Rijec a -> Rijec a
opG a xs=d xs:xs++[l xs]
opH :: Eq a => Abeceda a -> Rijec a -> Rijec a
opH a xs=d' a xs:xs++[l' a xs]
-- serial (union) and parallel (intersection) conjecture operators
opS :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opS a xs ys = inf a (l xs) (l ys) : inf a (l xs) (l ys) : xs ++
[sup a (d xs) (l ys),inf a (d xs) (l ys)] ++ ys ++
[sup a (d xs) (d ys),sup a (d xs) (d ys)]
opP :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
opP a xs ys = sup a (l xs) (l ys) : sup a (l xs) (l ys) : xs ++
[inf a (d xs) (l ys),sup a (d xs) (l ys)] ++ ys ++
[inf a (d xs) (d ys),inf a (d xs) (d ys)]
-- |partitions
particija :: Eq a => Abeceda a -> Rijec a -> Char
particija a xs | lijevi>=*lijevi' && desni<=*desni' && lijevi>*desni ='T'
| lijevi<=*lijevi' && desni<=*desni' && not (lijevi==lijevi' || desni==desni') ='A'
| lijevi==lijevi' && desni==desni' ='0'
| lijevi>=*lijevi' && desni>=*desni' && not (lijevi==lijevi' || desni==desni') ='Z'
| lijevi<=*lijevi' && desni>=*desni' && lijevi<*desni ='F'
where lijevi=l xs
desni=d xs
lijevi'=l' a xs
desni'=d' a xs
x >* y| m==Nothing || n==Nothing =error("Letter not in alphabet.")
| otherwise = (fromJust m) > (fromJust n)
where m=x `elemIndexAbc` a
n=y `elemIndexAbc` a
x >=* y = x >* y || x==y
x <* y = not (x >=* y)
x <=* y = not (x >* y)
-- implications
pimp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pimp a x y=(opK a x) `opP'` y
where opP'=opP a
simp :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
simp a x y=(opK a x) `opS'` y
where opS'=opS a
-- equivalencies
pekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
pekv a x y=(x `pimp'` y) `opS'` (y `pimp'` x)
where opS'=opS a
pimp'=pimp a
sekv :: Eq a => Abeceda a -> Rijec a -> Rijec a -> Rijec a
sekv a x y=(x `simp'` y) `opP'` (y `simp'` x)
where opP'=opP a
simp'=simp a
-- |tautologies and rules
taut :: Eq a => Abeceda a -> Rijec a ->Rijec a -> Rijec a -> [(String,Char)]
taut a x y z= zip
["1.ZAKON ISKLJUCENJA TRECEG",
"2.DUAL ZAKONA ISKLJUCENJA TRECEG",
"3.TRANZITIVNOST IMPLIKACIJE",
"4.DUAL TRANZITIVNOSTI IMPLIKACIJE",
"5.ZAKON DVOSTRUKE NEGACIJE",
"6.ZAKON KONTRAPOZICIJE",
"7.DUAL ZAKONA KONTRAPOZICIJE",
"8.ZAKON APSORPCIJE ILI UPIJANJA",
"9.DUAL ZAKONA APSORPCIJE ILI UPIJANJA",
"10.MODUS PONENDO PONENS",
"11.DUAL MODUSA PONENDO PONENS",
"12.MODUS TOLENDO TOLLENS",
"13.DOKAZ NABRAJANJEM",
"14.DOVODJENJE DO PROTURJECJA"]
(map (particija a) [
x `opP'` (neg x),
x `opS'` (neg x),
((x `pimp'` y) `opS'` (y `pimp'` z)) `pimp'` (x `pimp'` z),
((x `simp'` y) `opP'` (y `simp'` z)) `simp'` (x `simp'` z),
(neg (neg x)) `pekv'` x,
(x `pimp'` y) `pimp'` ((neg y) `pimp'` (neg x)),
(x `simp'` y) `simp'` ((neg y) `simp'` (neg x)),
(x `opP'` (y `opP'` x)) `pimp'` x,
(x `opS'` (y `opS'` x)) `simp'` x,
(x `opS'` (x `pimp'` y)) `pimp'` y,
(x `opP'` (x `simp'` y)) `simp'` y,
((neg x) `opS'` ((neg x) `pimp'` (neg y))) `pimp'` (neg y),
((x `pimp'` z) `opS'` (y `pimp'` z)) `pimp'` ((x `opP'` y) `pimp'` z),
((x `pimp'` y) `opS'` (x `pimp'` (neg y))) `pimp'` (neg x)
]
)
where opP'=opP a
opS'=opS a
pimp'=pimp a
simp'=simp a
pekv'=pekv a
sekv'=sekv a
neg=opK a
{-# START_FILE Main.hs #-}
{-# LANGUAGE UndecidableInstances, FlexibleInstances, OverlappingInstances, IncoherentInstances #-}
module Main where
import Linguistic2
main :: IO ()
-- show Set alphabet and variables.
main=do let {a = lista2abeceda ['a'..'z']; -- <-- CHANGE
x = lista2rijec "ante"; -- <-- CHANGE
y = lista2rijec "koba"; -- <-- CHANGE
-- ADD MORE VARIABLES IF NECESSARY
}
-- /show
-- show Operators that can be used in the expression
let opDa =opD a; -- unary
opEa =opE a; -- unary
opFa =opF a; -- unary
opIa =opI a; -- unary
opGa =opG a; -- unary
opHa =opH a; -- unary
neg =opK a; -- unary
opKsa =opKs a; -- unary
opKpa =opKp a; -- unary
opJsa =opJs a; -- unary
opJpa =opJp a; -- unary
sLjuskaa =sLjuska a; -- unary
pLjuskaa =pLjuska a; -- unary
opIsa =opIs a; -- unary
opIpa =opIp a; -- unary
opSa =opS a; -- binary
opPa =opP a; -- binary
opSminusa =opSminus a; -- binary
opPminusa =opPminus a; -- binary
pimpa =pimp a; -- binary
simpa =simp a; -- binary
pekva =pekv a; -- binary
sekva =sekv a; -- binary
kratia =krati a; -- unary
-- /show
let izraz=
-- show Set the expression
opIsa y -- <-- CHANGE
-- /show
putStrLn (ispis izraz);
putStrLn ("Length:"++show (duljina a izraz));
putStrLn ("Defect:"++show (defekt a izraz));
putStrLn ("s-length:"++show (sDuljina a izraz));
putStrLn ("p-length:"++show (pDuljina a izraz));