Guest User

Untitled

a guest
Apr 24th, 2018
75
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 2.88 KB | None | 0 0
  1. module Test(MyType,x,y,z,createMyType) where
  2.  
  3. data MyType = MT { x :: Int, y :: Int, z :: Int }
  4.  
  5. createMyType :: Int -> Int -> MyType
  6. createMyType myX myY = MT { x = myX, y = myY, z = 5 - myX - myY }
  7.  
  8. {-# LANGUAGE GADTs, TypeFamilies, RankNTypes, StandaloneDeriving, UndecidableInstances, TypeOperators #-}
  9.  
  10. data Z = Z
  11. data S n = S n
  12.  
  13. data Nat n where
  14. Zero :: Nat Z
  15. Suc :: Nat n -> Nat (S n)
  16.  
  17. deriving instance Show (Nat n)
  18.  
  19. type family (:+) a b :: *
  20. type instance (:+) Z b = b
  21. type instance (:+) (S a) b = S (a :+ b)
  22.  
  23. plus :: Nat x -> Nat y -> Nat (x :+ y)
  24. plus Zero y = y
  25. plus (Suc x) y = Suc (x `plus` y)
  26.  
  27. type family (:*) a b :: *
  28. type instance (:*) Z b = Z
  29. type instance (:*) (S a) b = b :+ (a :* b)
  30.  
  31. times :: Nat x -> Nat y -> Nat (x :* y)
  32. times Zero y = Zero
  33. times (Suc x) y = y `plus` (x `times` y)
  34.  
  35. data (:==) a b where
  36. Refl :: a :== a
  37.  
  38. deriving instance Show (a :== b)
  39.  
  40. cong :: a :== b -> f a :== f b
  41. cong Refl = Refl
  42.  
  43. data Triple where
  44. Triple :: Nat x -> Nat y -> Nat z -> (z :== (x :+ y)) -> Triple
  45.  
  46. deriving instance Show Triple
  47.  
  48. -- Half a decision procedure
  49. equal :: Nat x -> Nat y -> Maybe (x :== y)
  50. equal Zero Zero = Just Refl
  51. equal (Suc x) Zero = Nothing
  52. equal Zero (Suc y) = Nothing
  53. equal (Suc x) (Suc y) = cong `fmap` equal x y
  54.  
  55. triple' :: Nat x -> Nat y -> Nat z -> Maybe Triple
  56. triple' x y z = fmap (Triple x y z) $ equal z (x `plus` y)
  57.  
  58. toNat :: (forall n. Nat n -> r) -> Integer -> r
  59. toNat f n | n < 0 = error "why can't we have a natural type?"
  60. toNat f 0 = f Zero
  61. toNat f n = toNat (f . Suc) (n - 1)
  62.  
  63. triple :: Integer -> Integer -> Integer -> Maybe Triple
  64. triple x y z = toNat (x' -> toNat (y' -> toNat (z' -> triple' x' y' z') z) y) x
  65.  
  66. data Yatima where
  67. Yatima :: Nat x -> Nat y -> Nat z -> ((x :* x) :+ (y :* y) :+ (z :* z) :== S (S (S (S (S Z))))) -> Yatima
  68.  
  69. deriving instance Show Yatima
  70.  
  71. yatima' :: Nat x -> Nat y -> Nat z -> Maybe Yatima
  72. yatima' x y z =
  73. fmap (Yatima x y z) $ equal ((x `times` x) `plus` (y `times` y) `plus` (z `times` z)) (Suc (Suc (Suc (Suc (Suc Zero)))))
  74.  
  75. yatima :: Integer -> Integer -> Integer -> Maybe Yatima
  76. yatima x y z = toNat (x' -> toNat (y' -> toNat (z' -> yatima' x' y' z') z) y) x
  77.  
  78.  
  79. {-
  80. λ> triple 3 4 5
  81. Nothing
  82. λ> triple 3 4 7
  83. Just (Triple (Suc (Suc (Suc Zero))) (Suc (Suc (Suc (Suc Zero)))) Refl (Suc (Suc (Suc (Suc (Suc (Suc (Suc Zero))))))))
  84.  
  85. λ> yatima 0 1 2
  86. Just (Yatima Zero (Suc Zero) (Suc (Suc Zero)) Refl)
  87. λ> yatima 1 1 2
  88. Nothing
  89. -}
  90.  
  91. open import Relation.Binary.PropositionalEquality (_≡_)
  92. open import Data.Nat (ℕ; _+_)
  93. open import Data.Product (Σ; ×; _,_)
  94.  
  95. FiveTriple : Set
  96. FiveTriple = Σ (ℕ × ℕ × ℕ) (λ{ (x , y , z) → x + y + z ≡ 5 })
  97.  
  98. someFiveTriple : FiveTriple
  99. someFiveTriple = (0 , 2 , 5) , refl
  100.  
  101. data MyType = MT {x :: Int, y :: Int, z :: Int } deriving Show
  102.  
  103. createMyType :: Int -> Int -> Int -> Maybe MyType
  104. createMyType a b c
  105. | a + b + c == 5 = Just MT { x = a, y = b, z = c }
  106. | otherwise = Nothing
Add Comment
Please, Sign In to add comment