├── .gitignore ├── README.md ├── examples ├── effect-examples.tgz ├── effect-examples │ ├── FileTest.idr │ ├── ImpLang.idr │ ├── Lang.idr │ ├── Queens.idr │ ├── ioreason.idr │ └── testFile └── type_classes_hack.lidr ├── frameworks ├── 11-14 │ ├── Bool │ │ └── Postulates.lidr │ ├── BoundedNat │ │ └── Blt.lidr │ ├── DynamicProgramming │ │ ├── README │ │ ├── S000_Introduction.lidr │ │ ├── S100_FiniteHorizon.lidr │ │ ├── S1100_ConstantState_DeterministicTransition.lidr │ │ ├── S1101_Context.lidr │ │ ├── S1102_OptimalControls.lidr │ │ ├── S1103_OptimalPolicies.lidr │ │ ├── S1104_MaxArgmax.lidr │ │ ├── S1105_BackwardsInduction.lidr │ │ ├── S1106_Example1.lidr │ │ ├── S1106_Example2.lidr │ │ ├── S1106_Example3_CostEstimates.lidr │ │ ├── S1106_Knapsack.lidr │ │ ├── S1107_FiniteState.lidr │ │ ├── S1108_TabulatedBackwardsInduction.lidr │ │ ├── S1109_Example1.lidr │ │ ├── S1109_Example2.lidr │ │ ├── S1200_TimeDependentState_DeterministicTransition.lidr │ │ ├── S1201_Context.lidr │ │ ├── S1202_ReachabilityViability.lidr │ │ ├── S1202_ReachabilityViabilityDefaults.lidr │ │ ├── S1203_Controls.lidr │ │ ├── S1203_OptimalControls.lidr │ │ ├── S1203_OptimalPolicies.lidr │ │ ├── S1204_MaxArgmax.lidr │ │ ├── S1205_BackwardsInduction.lidr │ │ ├── S1206_Example1.lidr │ │ ├── S1206_Example2.lidr │ │ ├── S1206_Example3.lidr │ │ ├── S1206_Example3.out │ │ ├── S1206_Example4.2014-04.out │ │ ├── S1206_Example4.2014-08-03.out │ │ ├── S1206_Example4.2014-09-10.out │ │ ├── S1206_Example4.2014-10-06.out │ │ ├── S1206_Example4.2014-11-11.out │ │ ├── S1206_Example4.lidr │ │ ├── S1206_Example4.out │ │ ├── S1207_FiniteState.lidr │ │ ├── S1208_TabulatedBackwardsInduction.lidr │ │ ├── S1209_Example1.lidr │ │ ├── S1209_Example2.lidr │ │ ├── S1300_TimeDependentState_GeneralTransition.lidr │ │ ├── S1301_Context.lidr │ │ ├── S1302_Feasibility.lidr │ │ ├── S1302_Reachability.lidr │ │ ├── S1302_ReachabilityDefaults.lidr │ │ ├── S1302_Viability.lidr │ │ ├── S1302_ViabilityDefaults.lidr │ │ ├── S1303_Controls.lidr │ │ ├── S1303_OptimalPolicies.lidr │ │ ├── S1303_Trajectories.lidr │ │ ├── S1304_MaxArgmax.lidr │ │ ├── S1305_BackwardsInduction.lidr │ │ ├── S1306_ClimateChangePolicyUnderTippingPointUncertainty.lidr │ │ ├── S1306_Example1.lidr │ │ ├── S1306_Example2.lidr │ │ ├── S1306_Example3.lidr │ │ ├── S1306_Example4.lidr │ │ ├── S1306_Example5.lidr │ │ ├── S1307_FiniteState.lidr │ │ ├── S1308_TabulatedBackwardsInduction.lidr │ │ ├── S1309_ClimateChangePolicyUnderTippingPointUncertainty.lidr │ │ ├── S1309_ClimateChangePolicyUnderTippingPointUncertaintyVersion2.lidr │ │ ├── S1309_Example2.lidr │ │ ├── S1309_Example4.lidr │ │ ├── commands.txt │ │ ├── done.2012-12-19 │ │ ├── todo.2012-12-16 │ │ └── todo.meeting_with_edwin │ ├── DynamicProgrammingSmall │ │ ├── S1301_Context.lidr │ │ ├── S1302_Feasibility.lidr │ │ ├── S1302_Reachability.lidr │ │ ├── S1302_Viability.lidr │ │ ├── S1303_Controls.lidr │ │ ├── S1303_OptimalPolicies.lidr │ │ ├── S1303_Trajectories.lidr │ │ ├── S1304_MaxArgmax.lidr │ │ ├── S1305_BackwardsInduction.lidr │ │ ├── S1307_FiniteState.lidr │ │ ├── S1308_TabulatedBackwardsInduction.lidr │ │ └── S1309_Example2.lidr │ ├── EffectException.lidr │ ├── EffectStdIO.lidr │ ├── Exists │ │ └── Ops.lidr │ ├── Float │ │ ├── Float.lidr │ │ ├── Postulates.lidr │ │ └── Properties.lidr │ ├── Fun │ │ ├── Fun.lidr │ │ ├── Ops.lidr │ │ └── Ops1.lidr │ ├── Logic │ │ ├── Ops.lidr │ │ ├── Postulates.lidr │ │ └── Properties.lidr │ ├── Makefile │ ├── Nat │ │ ├── Ops.lidr │ │ ├── Postulates.lidr │ │ └── Properties.lidr │ ├── NatProperties.lidr │ ├── Preorder.lidr │ ├── Prob │ │ └── SimpleProb1.lidr │ ├── Rel │ │ ├── DecEq.lidr │ │ ├── EqEq.lidr │ │ ├── Postulates.lidr │ │ ├── Properties.lidr │ │ ├── ReflDecEq.lidr │ │ ├── ReflEqEq.lidr │ │ └── Syntax.lidr │ ├── TotalPreorder.lidr │ ├── Util │ │ ├── Opt.lidr │ │ ├── Util.lidr │ │ ├── VectExtensions1.lidr │ │ └── testVectExtensions1.lidr │ └── Vect │ │ └── Ops.lidr └── 14- │ ├── .gitignore │ ├── Basics.lidr │ ├── BoundedNat.lidr │ ├── BoundedNatOperations.lidr │ ├── BoundedNatProperties.lidr │ ├── Decidable.lidr │ ├── DecidableProperties.lidr │ ├── EffectException.lidr │ ├── EffectStdIO.lidr │ ├── EqualityProperties.lidr │ ├── ExistsOperations.lidr │ ├── FinOperations.lidr │ ├── FinProperties.lidr │ ├── Finite.lidr │ ├── FiniteOperations.lidr │ ├── FiniteProperties.lidr │ ├── FiniteSubType.lidr │ ├── FiniteSubTypeOperations.lidr │ ├── FiniteSubTypeProperties.lidr │ ├── Fraction.lidr │ ├── FractionBasicOperations.lidr │ ├── FractionBasicProperties.lidr │ ├── FractionEqProperties.lidr │ ├── FractionLTEProperties.lidr │ ├── FractionNormal.lidr │ ├── FractionNormalize.lidr │ ├── FractionNormalizeProperties.lidr │ ├── FractionPredicates.lidr │ ├── FractionTest.lidr │ ├── FunOperations.lidr │ ├── FunProperties.lidr │ ├── IdentityOperations.lidr │ ├── IdentityProperties.lidr │ ├── IsomorphismOperations.lidr │ ├── IsomorphismProperties.lidr │ ├── Issue3405.lidr │ ├── KernelQuotient.lidr │ ├── LeftAheadRight.lidr │ ├── ListOperations.lidr │ ├── ListOperationsTest.lidr │ ├── ListProperties.lidr │ ├── Makefile │ ├── Matrix.lidr │ ├── MatrixOperations.lidr │ ├── NatBasicProperties.lidr │ ├── NatCoprime.lidr │ ├── NatCoprimeProperties.lidr │ ├── NatDivisor.lidr │ ├── NatDivisorOperations.lidr │ ├── NatDivisorProperties.lidr │ ├── NatGCD.lidr │ ├── NatGCDAlgorithm.lidr │ ├── NatGCDAlgorithmTest.1.lidr │ ├── NatGCDAlgorithmTest.2.lidr │ ├── NatGCDEuclid.lidr │ ├── NatGCDEuclidStrippedDown.lidr │ ├── NatGCDEuclidStrippedDownTest.lidr │ ├── NatGCDEuclidTest.lidr │ ├── NatGCDOperations.lidr │ ├── NatGCDProperties.lidr │ ├── NatLTEProperties.lidr │ ├── NatLTProperties.lidr │ ├── NatOperations.lidr │ ├── NatOperationsProperties.lidr │ ├── NatPositive.lidr │ ├── NatPredicates.lidr │ ├── NatProperties.TODO │ ├── NonNegRational.lidr │ ├── NonNegRational2.lidr │ ├── NonNegRational3001.lidr │ ├── NonNegRationalBasicOperations.lidr │ ├── NonNegRationalBasicProperties.lidr │ ├── NonNegRationalBasicTests.lidr │ ├── NonNegRationalLTEProperties.lidr │ ├── NonNegRationalMeasureProperties.lidr │ ├── NonNegRationalMeasures.lidr │ ├── NonNegRationalPredicates.lidr │ ├── NonNegRationalProperties.lidr │ ├── NonNegRationalTest2.lidr │ ├── NumOperations.lidr │ ├── NumProperties.lidr │ ├── NumRefinements.lidr │ ├── Opt.lidr │ ├── PNat.lidr │ ├── PNatOperations.lidr │ ├── PNatProperties.lidr │ ├── PairProperties.lidr │ ├── PairsOperations.lidr │ ├── Preorder.lidr │ ├── Prop.lidr │ ├── README.md │ ├── SeqDecProbMonadicSmallTheoryRV.lidr │ ├── SeqDecProbMonadicSmallTheoryRVExample2.lidr │ ├── SeqDecProbsCoreAssumptions.lidr │ ├── SeqDecProbsCoreTheory.lidr │ ├── SeqDecProbsExample1.lidr │ ├── SeqDecProbsExample1tab.lidr │ ├── SeqDecProbsExample2.lidr │ ├── SeqDecProbsExample2tab.lidr │ ├── SeqDecProbsExample3.lidr │ ├── SeqDecProbsExample4.lidr │ ├── SeqDecProbsExample5.lidr │ ├── SeqDecProbsHelpers.lidr │ ├── SeqDecProbsTabulatedBackwardsInduction.lidr │ ├── SeqDecProbsUtils.lidr │ ├── Sigma.lidr │ ├── SigmaOperations.lidr │ ├── SigmaProperties.lidr │ ├── SignProperties.lidr │ ├── SimpleProb.lidr │ ├── SimpleProbBasicOperations.lidr │ ├── SimpleProbBasicProperties.lidr │ ├── SimpleProbMeasures.lidr │ ├── SimpleProbMonadicOperations.lidr │ ├── SimpleProbMonadicProperties.lidr │ ├── SoProperties.lidr │ ├── SplitQuotient.lidr │ ├── SubType.lidr │ ├── SubsetOperations.lidr │ ├── SubsetProperties.lidr │ ├── TestFractionBasicOperations.lidr │ ├── TestNatBasic1.lidr │ ├── TestNonNegRationalBasic1.lidr │ ├── TestNonNegRationalBasic2.lidr │ ├── TestNonNegRationalBasic3.lidr │ ├── TestNonNegRationalBasic4.lidr │ ├── TestNonNegRationalEquality.lidr │ ├── TestNonNegRationalMeasures.lidr │ ├── TestPNatOperations.lidr │ ├── TestSimpleProbBasic1.lidr │ ├── TestSimpleProbBasic2.lidr │ ├── TestTypeCheckingSpeed.lidr │ ├── TotalPreorder.lidr │ ├── TotalPreorderOperations.lidr │ ├── Unique.lidr │ ├── UniqueProperties.lidr │ ├── UnitProperties.lidr │ ├── VectOperations.lidr │ ├── VectProperties.lidr │ ├── VoidProperties.lidr │ ├── errors.txt │ ├── issue3405.ipkg │ ├── log.txt │ ├── tests │ ├── Makefile │ ├── melvarDivMod.lidr │ ├── nicolaDivMod.lidr │ └── standardDivMod.lidr │ ├── unused │ ├── EmbProj.lidr │ └── tagging.lidr │ └── zombies │ ├── BareFraction.lidr │ ├── ClassContainerMonad.lidr │ ├── ContainerMonad.lidr │ ├── DivMod.lidr │ ├── FractionImplementationIndependentProperties.lidr │ ├── FractionNatPairImplementation.lidr │ ├── FractionOperations.lidr │ ├── FractionProperties.lidr │ ├── FractionReduction.lidr │ ├── FractionReductionOperations.lidr │ ├── FractionReductionProperties.lidr │ ├── FractionSpecification.lidr │ ├── LambdaPostulates.lidr │ ├── NatGCDEuclidStrippedDown.lidr │ ├── NatProperties.lidr │ ├── NonNegQ.lidr │ ├── NonNegRationalOperations.lidr │ ├── Order.lidr │ ├── OrderOperations.lidr │ ├── OrderProperties.lidr │ ├── PreorderOperations.lidr │ ├── Rational.lidr │ ├── RationalOperations.lidr │ ├── RationalProperties.lidr │ ├── RationalSpecification.lidr │ ├── RelFloat.lidr │ ├── RelFloatPostulates.lidr │ ├── RelFloatProperties.lidr │ ├── RelSyntax.lidr │ ├── SeqDecProbMonadic.lidr │ ├── SeqDecProbMonadicExample1.1.lidr │ ├── SeqDecProbMonadicExample1.lidr │ ├── SeqDecProbMonadicExample2.0.lidr │ ├── SeqDecProbMonadicExample2.lidr │ ├── SeqDecProbMonadicExample3.lidr │ ├── SeqDecProbMonadicExampleAccident.lidr │ ├── SeqDecProbMonadicSmallTheory.lidr │ ├── SeqDecProbMonadicSmallTheoryExample2.lidr │ ├── SeqDecProbMonadicSmallTheoryRV.lidr │ ├── SeqDecProbMonadicSmallTheoryRVExample2.lidr │ ├── SeqDecProbMonadicSmallTheoryV.lidr │ ├── SeqDecProbMonadicSmallTheoryVExample2.lidr │ ├── SeqDecProbMonadicTheory.0.lidr │ ├── SeqDecProbMonadicTheory.lidr │ ├── SeqDecProbMonadicTheoryExample2.1.lidr │ ├── SeqDecProbMonadicTheoryExample2.lidr │ ├── SeqDecProbMonadicTheoryRVExample2b.lidr │ ├── SeqDecProbMonadicUtils.lidr │ ├── SeqDecProbsCoreTheory.0.lidr │ ├── SeqDecProbsTabulatedBackwardsInduction.0.lidr │ ├── SignedPredicates.lidr │ ├── SoProperties.lidr │ └── Util.lidr ├── idris-lang ├── injective_filter_lemma.2.lidr ├── injective_filter_lemma.3.lidr ├── injective_filter_lemma.4.lidr └── injective_filter_lemma.lidr ├── issue_reports ├── 2986 │ └── SimpleProb2986.lidr ├── 3024 │ ├── Bar.lidr │ ├── Bar1.lidr │ ├── Bar2.lidr │ ├── Foo.lidr │ └── Main.lidr ├── 3030 │ ├── A.lidr │ ├── B.lidr │ ├── Foo.lidr │ └── Main.lidr ├── 3031 │ ├── auto_implicits.1.lidr │ ├── auto_implicits.2.lidr │ └── auto_implicits.lidr ├── 3038 │ └── BoringParsers.lidr ├── 3078 │ └── NumProperties.lidr ├── 1856_explicitsExpansion.lidr ├── 1856_implicitsExpansion.lidr ├── 1916_disambiguation.lidr ├── 1920_unification.lidr ├── 1928_totality_checker.lidr ├── 1990_lambda.lidr ├── 1993_type_classes.lidr ├── 2014_type_classes.lidr ├── 2039_unification.lidr ├── 2053_derived_instances.1.lidr ├── 2053_derived_instances.lidr ├── 2057_type_classes.lidr ├── 2058_namespaces.1.lidr ├── 2058_namespaces.2.lidr ├── 2058_namespaces.3.lidr ├── 2130_non-exaustive_patterns.lidr ├── 2133_unification.lidr ├── 2150_internal_error.lidr ├── 2261_sigma_equality.lidr ├── 2322_internal_error.lidr ├── 2325_show.lidr ├── 2325_show_1.lidr ├── 2326_show.lidr ├── 2778_names_do_matter_where_they_should_not │ └── Fraction2778.lidr ├── 3079_hide │ ├── Decidable.lidr │ ├── Sigma.lidr │ └── TestSigma.lidr ├── 3209.lidr ├── PatternMatchImplicit1.lidr ├── disambiguate.lidr ├── doubleimport │ ├── A.idr │ ├── B.idr │ ├── C.idr │ └── D │ │ ├── A.idr │ │ ├── B.idr │ │ └── C.idr ├── equality.lidr ├── equalitySimple.lidr ├── equalitySimpler.lidr ├── filterTag.lidr ├── num_type_mismatch │ ├── Fraction.lidr │ ├── FractionNormal.lidr │ ├── FractionOperations.lidr │ ├── FractionProperties.lidr │ ├── Makefile │ ├── NatPositive.lidr │ ├── NonNegRational.lidr │ ├── NonNegRationalOperations.lidr │ ├── NonNegRationalProperties.lidr │ ├── NonNegRationalTest.lidr │ ├── PNat.lidr │ ├── PNatOperations.lidr │ └── PNatProperties.lidr ├── preorderReasoning.lidr ├── totalityChecker.lidr ├── totalityChecker1.lidr ├── typeClasses.lidr └── typeClasses1.lidr ├── manuscripts ├── 2014.LMCS │ └── code │ │ ├── .gitignore │ │ ├── Bool │ │ └── Postulates.lidr │ │ ├── BoundedNat │ │ └── Blt.lidr │ │ ├── Double │ │ ├── Double.lidr │ │ ├── Postulates.lidr │ │ └── Properties.lidr │ │ ├── DynamicProgramming │ │ ├── S1101_Context.lidr │ │ ├── S1102_OptimalControls.lidr │ │ ├── S1103_OptimalPolicies.lidr │ │ ├── S1104_MaxArgmax.lidr │ │ ├── S1105_BackwardsInduction.lidr │ │ ├── S1106_KnapsackExample.lidr │ │ ├── S1201_Context.lidr │ │ ├── S1202_ReachabilityViability.lidr │ │ ├── S1202_ReachabilityViabilityDefaults.lidr │ │ ├── S1203_Controls.lidr │ │ ├── S1203_OptimalControls.lidr │ │ ├── S1203_OptimalPolicies.lidr │ │ ├── S1204_MaxArgmax.lidr │ │ ├── S1205_BackwardsInduction.lidr │ │ ├── S1206_CylinderExample1.lidr │ │ ├── S1206_CylinderExample4.lidr │ │ ├── S1301_Context.lidr │ │ ├── S1302_Reachability.lidr │ │ ├── S1302_Viability.lidr │ │ ├── S1302_ViabilityDefaults.lidr │ │ ├── S1303_OptimalPolicies.lidr │ │ ├── S1303_Trajectories.lidr │ │ ├── S1304_MaxArgmax.lidr │ │ ├── S1305_BackwardsInduction.lidr │ │ └── TODO.md │ │ ├── EffectException.lidr │ │ ├── EffectStdIO.lidr │ │ ├── Exists │ │ └── Ops.lidr │ │ ├── Fun │ │ └── Ops.lidr │ │ ├── List │ │ └── Ops.lidr │ │ ├── Logic │ │ ├── Ops.lidr │ │ ├── Postulates.lidr │ │ └── Properties.lidr │ │ ├── Makefile │ │ ├── Nat │ │ ├── Operations.lidr │ │ ├── Postulates.lidr │ │ └── Properties.lidr │ │ ├── Prob │ │ ├── SimpleProb.lidr │ │ └── testSimpleProb.lidr │ │ ├── README.md │ │ ├── Rel │ │ ├── DecEq.lidr │ │ ├── EqEq.lidr │ │ ├── Postulates.lidr │ │ ├── Properties.lidr │ │ ├── ReflDecEq.lidr │ │ ├── ReflEqEq.lidr │ │ └── Syntax.lidr │ │ ├── Set │ │ └── SetIsType.lidr │ │ ├── Util │ │ ├── Opt.lidr │ │ ├── Util.lidr │ │ └── VectExtensions1.lidr │ │ ├── Vect │ │ └── Ops.lidr │ │ └── log.txt └── 2015.JFP │ └── code │ ├── README.md │ ├── deterministic.lidr │ ├── funprogintro.lidr │ ├── monadic.lidr │ ├── non-deterministic.lidr │ ├── preliminaries.lidr │ └── stochastic.lidr ├── notes └── 2015-06-05.md ├── old ├── Pigeonhole.lidr ├── finite.lidr └── stochastic.lidr ├── prototypes ├── PreTab.lidr └── pretab.ipkg └── talks ├── 2015.06.rd4_seminar ├── Makefile ├── asymptote.sty ├── black.lhs ├── code │ ├── Decidable.lidr │ ├── Finite.lidr │ ├── Nat.lidr │ ├── NatProperties.lidr │ ├── Preorder.lidr │ ├── Prob.lidr │ ├── Theory.lidr │ └── TotalPreorder.lidr ├── gray.lhs ├── macros.TeX ├── red.lhs ├── schellnhuber.pdf ├── slides.fmt ├── slides.lhs └── slides.pdf └── 2016-11_Oxford ├── .gitignore ├── Avoidability.md ├── Example.hs ├── LICENSE ├── SeqDecProbs.cabal ├── Setup.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | *.ibc 2 | *~ 3 | -------------------------------------------------------------------------------- /examples/effect-examples.tgz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nicolabotta/SeqDecProbs/1320e64dfd138f47aefac8b418231b05bd779f34/examples/effect-examples.tgz -------------------------------------------------------------------------------- /examples/effect-examples/FileTest.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Effect.File 4 | import Effect.State 5 | import Effect.StdIO 6 | import Control.IOExcept 7 | 8 | data FName = Count | NotCount 9 | 10 | FileIO : Type -> Type -> Type 11 | FileIO st t 12 | = Eff (IOExcept String) [FILE_IO st, STDIO, Count ::: STATE Int] t 13 | 14 | readFile : FileIO (OpenFile Read) (List String) 15 | readFile = readAcc [] where 16 | readAcc : List String -> FileIO (OpenFile Read) (List String) 17 | readAcc acc = do e <- eof 18 | if (not e) 19 | then do str <- readLine 20 | ls <- Count :- get 21 | Count :- put (ls + 1) 22 | readAcc (str :: acc) 23 | else return (reverse acc) 24 | 25 | testFile : FileIO () () 26 | testFile = catch (do open "testFile" Read 27 | str <- readFile 28 | putStrLn (show str) 29 | ls <- Count :- get 30 | close 31 | putStrLn (show ls)) 32 | (\err => putStrLn ("Handled: " ++ show err)) 33 | 34 | main : IO () 35 | main = do ioe_run (run [(), (), Count := 0] testFile) 36 | (\err => print err) (\ok => return ()) 37 | 38 | 39 | -------------------------------------------------------------------------------- /examples/effect-examples/Lang.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Effect.State 4 | import Effect.Exception 5 | import Effect.Random 6 | import Effect.StdIO 7 | 8 | data Expr = Var String 9 | | Val Int 10 | | Add Expr Expr 11 | | Random Int 12 | 13 | Env : Type 14 | Env = List (String, Int) 15 | 16 | -- Evaluator : Type -> Type 17 | -- Evaluator t 18 | -- = Eff m [EXCEPTION String, RND, STATE Env] t 19 | 20 | eval : Expr -> Eff IO [EXCEPTION String, STDIO, RND, STATE Env] Int 21 | eval (Var x) = do vs <- get 22 | case lookup x vs of 23 | Nothing => raise ("No such variable " ++ x) 24 | Just val => return val 25 | eval (Val x) = return x 26 | eval (Add l r) = [| eval l + eval r |] 27 | eval (Random upper) = do val <- rndInt 0 upper 28 | putStrLn (show val) 29 | return val 30 | 31 | testExpr : Expr 32 | testExpr = Add (Add (Var "foo") (Val 42)) (Random 100) 33 | 34 | runEval : List (String, Int) -> Expr -> IO Int 35 | runEval args expr = run [(), (), 123456, args] (eval expr) 36 | 37 | main : IO () 38 | main = do putStr "Number: " 39 | x <- getLine 40 | val <- runEval [("foo", cast x)] testExpr 41 | putStrLn $ "Answer: " ++ show val 42 | 43 | 44 | -------------------------------------------------------------------------------- /examples/effect-examples/Queens.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Effect.Select 4 | 5 | no_attack : (Int, Int) -> (Int, Int) -> Bool 6 | no_attack (x, y) (x', y') 7 | = x /= x' && y /= y' && abs (x - x') /= abs (y - y') 8 | 9 | rowsIn : Int -> List (Int, Int) -> List Int 10 | rowsIn col qs = [ x | x <- [1..8], all (no_attack (x, col)) qs ] 11 | 12 | addQueens : Int -> List (Int, Int) -> Eff m [SELECT] (List (Int, Int)) 13 | addQueens 0 qs = return qs 14 | addQueens col qs = do row <- select (rowsIn col qs) 15 | addQueens (col - 1) ((row, col) :: qs) 16 | 17 | getQueens : List (List (Int, Int)) 18 | getQueens = run [()] (addQueens 8 []) 19 | 20 | main : IO () 21 | main = do let qs = getQueens 22 | let num = the Int (cast (length qs)) 23 | putStrLn (show num ++ " solutions:\n" ++ showAll qs) 24 | where showAll [] = "" 25 | showAll (x :: xs) = show x ++ "\n" ++ showAll xs 26 | -------------------------------------------------------------------------------- /examples/effect-examples/ioreason.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Effect.StdIO 4 | import Effect.State 5 | 6 | test : Handler StdIO e => Eff e [STDIO, STATE String] () 7 | test = do putStr "Name? " 8 | n <- getStr 9 | put n 10 | putStrLn ("Hello " ++ show n) 11 | 12 | main : IO () 13 | main = run [(), ""] test 14 | 15 | -------------------------------------------------------------------------------- /examples/effect-examples/testFile: -------------------------------------------------------------------------------- 1 | HELLO!!! 2 | WORLD!!! 3 | -------------------------------------------------------------------------------- /frameworks/11-14/Bool/Postulates.lidr: -------------------------------------------------------------------------------- 1 | > module Postulates 2 | 3 | > import Data.So 4 | 5 | > import Rel.Syntax 6 | 7 | 8 | > postulate reflexive_Bool_eqeq : reflexive Bool (==) 9 | 10 | > postulate symmetric_Bool_eqeq : symmetric Bool (==) 11 | 12 | > postulate transitive_Bool_eqeq : transitive Bool (==) 13 | 14 | 15 | 16 | 17 | 18 | 19 | -------------------------------------------------------------------------------- /frameworks/11-14/BoundedNat/Blt.lidr: -------------------------------------------------------------------------------- 1 | > module Blt 2 | 3 | > import Data.So 4 | > import Data.Vect 5 | 6 | > import Nat.Postulates 7 | > import Exists.Ops 8 | > import Logic.Properties 9 | 10 | 11 | > %default total 12 | 13 | 14 | > Blt : Nat -> Type 15 | > Blt b = (n : Nat ** So (n < b)) 16 | 17 | > BltLemma0 : Blt Z -> alpha 18 | > BltLemma0 (Z ** p) = soFalseElim p 19 | > BltLemma0 (S n ** p) = soFalseElim p 20 | 21 | > toNat : Blt b -> Nat 22 | > toNat = outl 23 | 24 | > toFloat : Blt b -> Float 25 | > toFloat i = cast {from = Int} {to = Float} (cast {from = Nat} {to = Int} (Blt.toNat i)) 26 | 27 | -- > (==) : Blt b -> Blt b -> Bool 28 | -- > (==) i j = (toNat i == toNat j) 29 | 30 | > using (p : Nat -> Type) 31 | > instance Prelude.Show.Show (n : Nat ** p n) where 32 | > show (n ** _) = show n 33 | 34 | > using (p : Nat -> Type) 35 | > instance Eq (n : Nat ** p n) where 36 | > (==) (n ** _) (n' ** _) = n == n' 37 | 38 | > decBlt : (i : Blt b) -> (p : Blt.toNat i = S m) -> Blt b 39 | > decBlt (S k ** q) Refl = (k ** Sid_preserves_LT q) 40 | > decBlt ( Z ** q) Refl impossible 41 | 42 | > incBlt : (n : Blt b) -> So (S (Blt.toNat n) < b) -> Blt b 43 | > incBlt (k ** _) q = (S k ** q) 44 | 45 | > toVect : {b : Nat} -> (Blt b -> a) -> Vect b a 46 | > toVect {b = Z} _ = Nil 47 | > toVect {b = S b'} {a = a} f = ((f (Z ** Oh)) :: toVect f') where 48 | > f' : Blt b' -> a 49 | > f' (k ** q) = f (S k ** monotoneS q) 50 | 51 | -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/README: -------------------------------------------------------------------------------- 1 | Naming convention: 2 | ------------------ 3 | 4 | S11nn: the simplest case: deterministic, time-independent state 5 | 6 | S12nn: deterministic, time-dependent 7 | 8 | S13nn: monadic, time-dependent 9 | 10 | 11 | Note: 12 | ----- 13 | 14 | Not all files (are meant to) type check. Type checking certain files 15 | yields very large *.ibc files or consumes huge computational 16 | resources. In particular: 17 | 18 | - S1106_Example2.lidr does not type check. This is an instance of a 19 | problem discussed in issue #79. This issue has been closed but, in my 20 | view, the problem is still open. 21 | 22 | - S1206_Example3.lidr and S1206_Example4.lidr type check but yield *.ibc 23 | files which are about 1.5 GB each ! 24 | 25 | - Type checking of S1306_Example3.lidr and S1306_Example4.lidr 26 | stalls. After about 6 minutes the processes starts swapping memory 27 | after having consumed about 8GB of memory and produced .ibc files of 28 | about 500MB. CPU usage goes down to below 10% and type checking 29 | effectively stalls. 30 | 31 | - Type checking of S1309_Example2.lidr and 32 | S1309_ClimateChangePolicyUnderTippingPointUncertainty.lidr also stalls 33 | (after about 10 minutes) but no .ibc files is produced. 34 | -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S000_Introduction.lidr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nicolabotta/SeqDecProbs/1320e64dfd138f47aefac8b418231b05bd779f34/frameworks/11-14/DynamicProgramming/S000_Introduction.lidr -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S100_FiniteHorizon.lidr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nicolabotta/SeqDecProbs/1320e64dfd138f47aefac8b418231b05bd779f34/frameworks/11-14/DynamicProgramming/S100_FiniteHorizon.lidr -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S1100_ConstantState_DeterministicTransition.lidr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nicolabotta/SeqDecProbs/1320e64dfd138f47aefac8b418231b05bd779f34/frameworks/11-14/DynamicProgramming/S1100_ConstantState_DeterministicTransition.lidr -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S1104_MaxArgmax.lidr: -------------------------------------------------------------------------------- 1 | > module MaxArgmax 2 | 3 | > import Data.So 4 | 5 | > import DynamicProgramming.S1101_Context 6 | 7 | 8 | > %default total 9 | 10 | 11 | OptLemma shows that, given an optimal sequence of policies, an optimal 12 | sequence of controls can be easily computed for any initial value by 13 | means of |ctrl|. 14 | 15 | Thus, the problem of computing optimal sequences of controls is reduced 16 | to the problem of computing optimal sequences of policies. This can be 17 | done if we assume that, for all |x : X| and for all |f : Y x -> Float|, 18 | we are able to select a control |y : Y x| which maximises |f|. More 19 | precisely, we assume to have at our disposal 20 | 21 | > max : (x : X) -> (Y x -> Float) -> Float 22 | 23 | > argmax : (x : X) -> (Y x -> Float) -> Y x 24 | 25 | which fulfill the specifications 26 | 27 | > MaxSpec : Type 28 | > MaxSpec = (x : X) -> 29 | > (f : Y x -> Float) -> 30 | > (y : Y x) -> 31 | > So (f y <= max x f) 32 | 33 | > ArgmaxSpec : Type 34 | > ArgmaxSpec = (x : X) -> 35 | > (f : Y x -> Float) -> 36 | > So (f (argmax x f) == max x f) 37 | 38 | Thas is, we assume to be able to define |maxSpec| and |argmaxSpec| of 39 | type |MaxSpec|, |ArgmaxSpec|, respectively: 40 | 41 | > maxSpec : MaxSpec 42 | > argmaxSpec : ArgmaxSpec 43 | 44 | -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S1107_FiniteState.lidr: -------------------------------------------------------------------------------- 1 | > module FiniteState 2 | 3 | 4 | > import BoundedNat.Blt 5 | > import DynamicProgramming.S1101_Context 6 | 7 | > %default total 8 | 9 | 10 | # Finite state context extensions: 11 | 12 | > nX : Nat 13 | 14 | > index : X -> Blt nX 15 | 16 | > xedni : Blt nX -> X 17 | 18 | > IndexSpec : (x : X) -> x = xedni (index x) 19 | 20 | > XedniSpec : (i : Blt nX) -> i = index (xedni i) 21 | 22 | 23 | -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S1201_Context.lidr: -------------------------------------------------------------------------------- 1 | > module Context 2 | 3 | 4 | > %default total 5 | 6 | 7 | In the case of a time-dependent set of states and of a deterministic 8 | transition function, the context of a DP problem can be formalized in 9 | terms of: 10 | 11 | # A set of states |X|: 12 | 13 | > X : Nat -> Type 14 | 15 | # A set of controls or actions |Y t x|: 16 | 17 | > Y : (t : Nat) -> X t -> Type 18 | 19 | # A deterministic transition function: 20 | 21 | > step : (t : Nat) -> (x : X t) -> Y t x -> X (S t) 22 | 23 | # A reward function: 24 | 25 | > reward : (t : Nat) -> (x : X t) -> Y t x -> X (S t) -> Float 26 | 27 | -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S1203_Controls.lidr: -------------------------------------------------------------------------------- 1 | > module Controls 2 | 3 | 4 | > import Util.VectExtensions1 5 | > import DynamicProgramming.S1201_Context 6 | 7 | 8 | > %default total 9 | 10 | 11 | > eqeq : Y t x -> Y t x -> Bool 12 | 13 | > eqeqSpec1 : (y : Y t x) -> So (Controls.eqeq y y) 14 | 15 | These allow us to introduce the following abbreviations: 16 | 17 | > isIn : Y t x -> (n : Nat ** Vect n (Y t x)) -> Bool 18 | > isIn {t} {x} = VectExtensions1.isIn (Y t x) Controls.eqeq Controls.eqeqSpec1 19 | 20 | > lemma3 : (y : Y t x) -> 21 | > (p : Y t x -> Bool) -> 22 | > (ys : (n : Nat ** Vect n (Y t x))) -> 23 | > So (p y) -> 24 | > So (y `Controls.isIn` ys) -> 25 | > So (isAnyBy p ys) 26 | > lemma3 {t} {x} = VectExtensions1.lemma3 (Y t x) Controls.eqeq Controls.eqeqSpec1 27 | 28 | > whole : (n : Nat ** Vect n (Y t x)) -> Type 29 | > whole {t} {x} = VectExtensions1.whole (Y t x) Controls.eqeq Controls.eqeqSpec1 30 | -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S1206_Example3.out: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nicolabotta/SeqDecProbs/1320e64dfd138f47aefac8b418231b05bd779f34/frameworks/11-14/DynamicProgramming/S1206_Example3.out -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S1206_Example4.2014-04.out: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nicolabotta/SeqDecProbs/1320e64dfd138f47aefac8b418231b05bd779f34/frameworks/11-14/DynamicProgramming/S1206_Example4.2014-04.out -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S1206_Example4.2014-08-03.out: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nicolabotta/SeqDecProbs/1320e64dfd138f47aefac8b418231b05bd779f34/frameworks/11-14/DynamicProgramming/S1206_Example4.2014-08-03.out -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S1206_Example4.2014-09-10.out: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nicolabotta/SeqDecProbs/1320e64dfd138f47aefac8b418231b05bd779f34/frameworks/11-14/DynamicProgramming/S1206_Example4.2014-09-10.out -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S1206_Example4.2014-10-06.out: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nicolabotta/SeqDecProbs/1320e64dfd138f47aefac8b418231b05bd779f34/frameworks/11-14/DynamicProgramming/S1206_Example4.2014-10-06.out -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S1206_Example4.2014-11-11.out: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nicolabotta/SeqDecProbs/1320e64dfd138f47aefac8b418231b05bd779f34/frameworks/11-14/DynamicProgramming/S1206_Example4.2014-11-11.out -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S1206_Example4.out: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nicolabotta/SeqDecProbs/1320e64dfd138f47aefac8b418231b05bd779f34/frameworks/11-14/DynamicProgramming/S1206_Example4.out -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S1207_FiniteState.lidr: -------------------------------------------------------------------------------- 1 | > module FiniteState 2 | 3 | > import Data.So 4 | 5 | > import BoundedNat.Blt 6 | 7 | > import DynamicProgramming.S1201_Context 8 | > import DynamicProgramming.S1202_ReachabilityViability 9 | 10 | > %default total 11 | 12 | At the moment we need this only for implementing the linear version of 13 | backwars induction. We will reconsider the case in which |X| is finite 14 | later (maybe when we consider the additional assumptions we need to 15 | restrict the class of functions that can be passed to |argamax| and make 16 | |argmax| total). 17 | 18 | 19 | > nX : (t : Nat) -> (n : Nat) -> Nat 20 | 21 | |nX t n| is the cardinality of the set 22 | 23 | { x `in` X t | x is reachable and is viable for n steps } 24 | 25 | > index : (n : Nat) -> 26 | > (x : X t ** (So (reachable x), So (viable n x))) -> 27 | > Blt (nX t n) 28 | 29 | > xedni : (n : Nat) -> 30 | > Blt (nX t n) -> 31 | > (x : X t ** (So (reachable x), So (viable n x))) 32 | 33 | 34 | > IndexSpec : (n' : Nat) -> 35 | > (xrv : (x : X t ** (So (reachable {t} x), So (viable {t} n' x)))) -> 36 | > xrv = xedni n' (index n' xrv) 37 | 38 | > XedniSpec : (n : Nat) -> 39 | > (i : Blt (nX t n)) -> 40 | > i = index n (xedni n i) 41 | 42 | 43 | -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S1300_TimeDependentState_GeneralTransition.lidr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nicolabotta/SeqDecProbs/1320e64dfd138f47aefac8b418231b05bd779f34/frameworks/11-14/DynamicProgramming/S1300_TimeDependentState_GeneralTransition.lidr -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S1302_Feasibility.lidr: -------------------------------------------------------------------------------- 1 | > module Feasibility 2 | 3 | > import Data.So 4 | 5 | > import DynamicProgramming.S1301_Context 6 | > import DynamicProgramming.S1302_Viability 7 | 8 | > %default total 9 | 10 | 11 | > feasible : (n : Nat) -> (x : X t) -> Y t x -> Bool 12 | > feasible {t} n x y = MareAllTrue (Mmap (viable n) (step t x y)) 13 | 14 | First viability theorem, motivated by the implementation of yfysP, 15 | 16 | > viability1 : (x : X t) -> 17 | > So (viable (S n) x) -> 18 | > (y : Y t x ** So (feasible n x y)) 19 | 20 | The idea is: 21 | 22 | viable (S n) x 23 | = {def.} 24 | isAnyBy (\ mx => MareAllTrue (Mmap (viable n) mx)) (succs x) 25 | => {lemma3'} 26 | (mx' : M (X (S t)) ** mx' `isIn` (succs x) && MareAllTrue (Mmap (viable n) mx')) 27 | => {lemmaSuccs2} 28 | (y : Y t x ** mx' = step t x y) 29 | => {def. feasible n x y} 30 | (y : Y t x ** feasible n x y) 31 | 32 | > viability1 x v = believe_me Oh 33 | 34 | 35 | -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S1302_Reachability.lidr: -------------------------------------------------------------------------------- 1 | > module Reachability 2 | 3 | 4 | > import Data.So 5 | 6 | > import Util.VectExtensions1 7 | > import DynamicProgramming.S1301_Context 8 | 9 | 10 | > %default total 11 | 12 | 13 | > reachable : X t -> Bool 14 | 15 | > reachableSpec0 : (x : X Z) -> So (reachable x) 16 | 17 | > reachableSpec1 : (x : X t) -> 18 | > So (reachable x) -> 19 | > (y : Y t x) -> 20 | > (x' : X (S t)) -> 21 | > So (x' `MisIn` (step t x y)) -> 22 | > So (reachable x') 23 | 24 | > reachableSpec2 : (x' : X (S t)) -> 25 | > So (reachable x') -> 26 | > (x : X t ** (y : Y t x ** (So (reachable x), So (x' `MisIn` (step t x y))))) 27 | -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S1302_Viability.lidr: -------------------------------------------------------------------------------- 1 | > module Viability 2 | 3 | > import Data.So 4 | 5 | > import Util.VectExtensions1 6 | > import DynamicProgramming.S1301_Context 7 | 8 | > %default total 9 | 10 | 11 | > viable : (n : Nat) -> X t -> Bool 12 | 13 | > viableSpec0 : (x : X t) -> So (viable Z x) 14 | 15 | > viableSpec1 : 16 | > (x : X t) -> 17 | > So (viable (S n) x) -> 18 | > -- (y : Y t x ** So (x' `MisIn` (step t x y)) -> So (viable n x')) 19 | > (y : Y t x ** So (MareAllTrue (Mmap (viable n) (step t x y)))) 20 | 21 | > viableSpec2 : 22 | > (x : X t) -> 23 | > -- (y : Y t x ** So (x' `MisIn` (step t x y)) -> So (viable n x')) -> 24 | > (y : Y t x ** So (MareAllTrue (Mmap (viable n) (step t x y)))) -> 25 | > So (viable (S n) x) 26 | -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S1303_Controls.lidr: -------------------------------------------------------------------------------- 1 | > module Controls 2 | 3 | > import Data.So 4 | 5 | > import Util.VectExtensions1 6 | > import DynamicProgramming.S1301_Context 7 | 8 | > %default total 9 | 10 | 11 | > eqeq : Y t x -> Y t x -> Bool 12 | 13 | > -- eqeqSpec1 : (y : Y t x) -> So (eqeq y y) 14 | > eqeqSpec1 : (y : Y t x) -> So (Controls.eqeq y y) 15 | 16 | These allow us to introduce the following abbreviations: 17 | 18 | > isIn : Y t x -> (n : Nat ** Vect n (Y t x)) -> Bool 19 | > -- isIn {t} {x} = VectExtensions1.isIn (Y t x) eqeq eqeqSpec1 20 | > isIn {t} {x} = VectExtensions1.isIn (Y t x) Controls.eqeq Controls.eqeqSpec1 21 | 22 | > lemma3 : (y : Y t x) -> 23 | > (p : Y t x -> Bool) -> 24 | > (ys : (n : Nat ** Vect n (Y t x))) -> 25 | > So (p y) -> 26 | > -- So (y `isIn` ys) -> 27 | > So (y `Controls.isIn` ys) -> 28 | > So (isAnyBy p ys) 29 | > -- lemma3 {t} {x} = VectExtensions1.lemma3 (Y t x) eqeq eqeqSpec1 30 | > lemma3 {t} {x} = VectExtensions1.lemma3 (Y t x) Controls.eqeq Controls.eqeqSpec1 31 | 32 | > whole : (n : Nat ** Vect n (Y t x)) -> Type 33 | > -- whole {t} {x} = VectExtensions1.whole (Y t x) eqeq eqeqSpec1 34 | > whole {t} {x} = VectExtensions1.whole (Y t x) Controls.eqeq Controls.eqeqSpec1 35 | -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S1304_MaxArgmax.lidr: -------------------------------------------------------------------------------- 1 | > module MaxArgmax 2 | 3 | > import Data.So 4 | 5 | > import DynamicProgramming.S1301_Context 6 | > import DynamicProgramming.S1302_Reachability 7 | > import DynamicProgramming.S1302_Viability 8 | > import DynamicProgramming.S1302_Feasibility 9 | 10 | 11 | > max : (n : Nat) -> 12 | > (x : X t) -> 13 | > (r : So (reachable x)) -> 14 | > (v : So (viable (S n) x)) -> 15 | > (f : (y : Y t x ** So (feasible n x y))-> Float) -> 16 | > Float 17 | 18 | 19 | > argmax : (n : Nat) -> 20 | > (x : X t) -> 21 | > (r : So (reachable x)) -> 22 | > (v : So (viable (S n) x)) -> 23 | > (f : (y : Y t x ** So (feasible {t = t} n x y))-> Float) -> 24 | > (y : Y t x ** So (feasible {t = t} n x y)) 25 | 26 | 27 | > maxSpec : (n : Nat) -> 28 | > (x : X t) -> 29 | > (r : So (reachable {t} x)) -> 30 | > (v : So (viable {t} (S n) x)) -> 31 | > (f : (y : Y t x ** So (feasible n x y))-> Float) -> 32 | > (yv : (y : Y t x ** So (feasible n x y))) -> 33 | > So (f yv <= max n x r v f) 34 | 35 | > argmaxSpec : (n : Nat) -> 36 | > (x : X t) -> 37 | > (r : So (reachable x)) -> 38 | > (v : So (viable (S n) x)) -> 39 | > (f : (y : Y t x ** So (feasible {t = t} n x y))-> Float) -> 40 | > So (f (argmax n x r v f) == max n x r v f) 41 | 42 | -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/S1307_FiniteState.lidr: -------------------------------------------------------------------------------- 1 | > module FiniteState 2 | 3 | 4 | > import Data.So 5 | 6 | > import BoundedNat.Blt 7 | 8 | > import DynamicProgramming.S1301_Context 9 | > import DynamicProgramming.S1302_Reachability 10 | > import DynamicProgramming.S1302_Viability 11 | 12 | > %default total 13 | 14 | 15 | > nX : (t : Nat) -> (n : Nat) -> Nat 16 | 17 | 18 | > index : (n : Nat) -> 19 | > (x : X t ** (So (reachable x), So (viable n x))) -> 20 | > Blt (nX t n) 21 | 22 | > xedni : (n : Nat) -> 23 | > Blt (nX t n) -> 24 | > (x : X t ** (So (reachable x), So (viable n x))) 25 | 26 | 27 | > IndexSpec : (n' : Nat) -> 28 | > (xrv : (x : X t ** (So (reachable {t} x), So (viable {t} n' x)))) -> 29 | > xrv = xedni n' (index n' xrv) 30 | 31 | > XedniSpec : (n : Nat) -> 32 | > (i : Blt (nX t n)) -> 33 | > i = index n (xedni n i) 34 | 35 | 36 | -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/commands.txt: -------------------------------------------------------------------------------- 1 | getWitness (yfys 1 2 ((1 ** oh) ** oh) oh oh (\ y => 1.0)) 2 | 3 | getWitness (Prelude.Vect.filter (viable 2 2) [step 1 ((1 ** oh) ** oh) 4 | (Left ** oh), step 1 ((1 ** oh) ** oh) (Ahead ** oh), step 1 ((1 ** oh) 5 | ** oh) (Right ** oh)]) 6 | 7 | controls 1 3 ((1 ** oh) ** oh) oh oh (backwardsInduction 1 3) 8 | -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/done.2012-12-19: -------------------------------------------------------------------------------- 1 | - Implement a version of DP with time dependent state (and controls, 2 | transition and reward function) but without notions of reachability 3 | and viability. 4 | 5 | - Setup an example (e.g., with a barrier) for which such approach is not 6 | feasible. 7 | 8 | - Move to the time dependent case with reachability and viability 9 | constraints. 10 | 11 | - Think about how the notions of viability and reachability can be 12 | extended to the general case ! -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/todo.2012-12-16: -------------------------------------------------------------------------------- 1 | - Replace the specification of |max|, |argmax| with a specification for 2 | |argmaxMax| ? Maybe not. Even if the separate implementation of |max|, 3 | |argmax| is inefficient, only |argmax| is actually used in generic DP 4 | computations. |max| is only needed (if at all) for specifications. -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgramming/todo.meeting_with_edwin: -------------------------------------------------------------------------------- 1 | - S1306_Example4 does not type check in reasonable time if |step| is 2 | defined in terms of |convComb| even for zero |p|. -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgrammingSmall/S1302_Feasibility.lidr: -------------------------------------------------------------------------------- 1 | > module Feasibility 2 | 3 | > import Data.So 4 | 5 | > import DynamicProgrammingSmall.S1301_Context 6 | > import DynamicProgrammingSmall.S1302_Viability 7 | 8 | > %default total 9 | 10 | 11 | > feasible : (n : Nat) -> (x : X t) -> Y t x -> Bool 12 | > feasible {t} n x y = MareAllTrue (Mmap (viable n) (step t x y)) 13 | 14 | First viability theorem, motivated by the implementation of yfysP, 15 | 16 | > viability1 : (x : X t) -> 17 | > So (viable (S n) x) -> 18 | > (y : Y t x ** So (feasible n x y)) 19 | 20 | The idea is: 21 | 22 | viable (S n) x 23 | = {def.} 24 | isAnyBy (\ mx => MareAllTrue (Mmap (viable n) mx)) (succs x) 25 | => {lemma3'} 26 | (mx' : M (X (S t)) ** mx' `isIn` (succs x) && MareAllTrue (Mmap (viable n) mx')) 27 | => {lemmaSuccs2} 28 | (y : Y t x ** mx' = step t x y) 29 | => {def. feasible n x y} 30 | (y : Y t x ** feasible n x y) 31 | 32 | > viability1 x v = believe_me Oh 33 | 34 | 35 | -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgrammingSmall/S1302_Reachability.lidr: -------------------------------------------------------------------------------- 1 | > module Reachability 2 | 3 | 4 | > import Data.So 5 | 6 | > import Util.VectExtensions1 7 | 8 | > import DynamicProgrammingSmall.S1301_Context 9 | 10 | 11 | > %default total 12 | 13 | 14 | > reachable : X t -> Bool 15 | 16 | > reachableSpec0 : (x : X Z) -> So (reachable x) 17 | 18 | > reachableSpec1 : (x : X t) -> 19 | > So (reachable x) -> 20 | > (y : Y t x) -> 21 | > (x' : X (S t)) -> 22 | > So (x' `MisIn` (step t x y)) -> 23 | > So (reachable x') 24 | 25 | > reachableSpec2 : (x' : X (S t)) -> 26 | > So (reachable x') -> 27 | > (x : X t ** (y : Y t x ** (So (reachable x), So (x' `MisIn` (step t x y))))) 28 | -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgrammingSmall/S1302_Viability.lidr: -------------------------------------------------------------------------------- 1 | > module Viability 2 | 3 | > import Data.So 4 | 5 | > import Util.VectExtensions1 6 | 7 | > import DynamicProgrammingSmall.S1301_Context 8 | 9 | > %default total 10 | 11 | 12 | > viable : (n : Nat) -> X t -> Bool 13 | 14 | > viableSpec0 : (x : X t) -> So (viable Z x) 15 | 16 | > viableSpec1 : 17 | > (x : X t) -> 18 | > So (viable (S n) x) -> 19 | > -- (y : Y t x ** So (x' `MisIn` (step t x y)) -> So (viable n x')) 20 | > (y : Y t x ** So (MareAllTrue (Mmap (viable n) (step t x y)))) 21 | 22 | > viableSpec2 : 23 | > (x : X t) -> 24 | > -- (y : Y t x ** So (x' `MisIn` (step t x y)) -> So (viable n x')) -> 25 | > (y : Y t x ** So (MareAllTrue (Mmap (viable n) (step t x y)))) -> 26 | > So (viable (S n) x) 27 | -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgrammingSmall/S1303_Controls.lidr: -------------------------------------------------------------------------------- 1 | > module Controls 2 | 3 | > import Data.So 4 | 5 | > import Util.VectExtensions1 6 | 7 | > import DynamicProgrammingSmall.S1301_Context 8 | 9 | > %default total 10 | 11 | 12 | > eqeq : Y t x -> Y t x -> Bool 13 | 14 | > -- eqeqSpec1 : (y : Y t x) -> So (eqeq y y) 15 | > eqeqSpec1 : (y : Y t x) -> So (Controls.eqeq y y) 16 | 17 | These allow us to introduce the following abbreviations: 18 | 19 | > isIn : Y t x -> (n : Nat ** Vect n (Y t x)) -> Bool 20 | > -- isIn {t} {x} = VectExtensions1.isIn (Y t x) eqeq eqeqSpec1 21 | > isIn {t} {x} = VectExtensions1.isIn (Y t x) Controls.eqeq Controls.eqeqSpec1 22 | 23 | > lemma3 : (y : Y t x) -> 24 | > (p : Y t x -> Bool) -> 25 | > (ys : (n : Nat ** Vect n (Y t x))) -> 26 | > So (p y) -> 27 | > -- So (y `isIn` ys) -> 28 | > So (y `Controls.isIn` ys) -> 29 | > So (isAnyBy p ys) 30 | > -- lemma3 {t} {x} = VectExtensions1.lemma3 (Y t x) eqeq eqeqSpec1 31 | > lemma3 {t} {x} = VectExtensions1.lemma3 (Y t x) Controls.eqeq Controls.eqeqSpec1 32 | 33 | > whole : (n : Nat ** Vect n (Y t x)) -> Type 34 | > -- whole {t} {x} = VectExtensions1.whole (Y t x) eqeq eqeqSpec1 35 | > whole {t} {x} = VectExtensions1.whole (Y t x) Controls.eqeq Controls.eqeqSpec1 36 | -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgrammingSmall/S1304_MaxArgmax.lidr: -------------------------------------------------------------------------------- 1 | > module MaxArgmax 2 | 3 | > import Data.So 4 | 5 | > import DynamicProgrammingSmall.S1301_Context 6 | > import DynamicProgrammingSmall.S1302_Reachability 7 | > import DynamicProgrammingSmall.S1302_Viability 8 | > import DynamicProgrammingSmall.S1302_Feasibility 9 | 10 | 11 | > max : (n : Nat) -> 12 | > (x : X t) -> 13 | > (r : So (reachable x)) -> 14 | > (v : So (viable (S n) x)) -> 15 | > (f : (y : Y t x ** So (feasible n x y))-> Float) -> 16 | > Float 17 | 18 | 19 | > argmax : (n : Nat) -> 20 | > (x : X t) -> 21 | > (r : So (reachable x)) -> 22 | > (v : So (viable (S n) x)) -> 23 | > (f : (y : Y t x ** So (feasible {t = t} n x y))-> Float) -> 24 | > (y : Y t x ** So (feasible {t = t} n x y)) 25 | 26 | 27 | -------------------------------------------------------------------------------- /frameworks/11-14/DynamicProgrammingSmall/S1307_FiniteState.lidr: -------------------------------------------------------------------------------- 1 | > module FiniteState 2 | 3 | 4 | > import Data.So 5 | 6 | > import BoundedNat.Blt 7 | 8 | > import DynamicProgrammingSmall.S1301_Context 9 | > import DynamicProgrammingSmall.S1302_Reachability 10 | > import DynamicProgrammingSmall.S1302_Viability 11 | 12 | > %default total 13 | 14 | 15 | > nX : (t : Nat) -> (n : Nat) -> Nat 16 | 17 | 18 | > index : (n : Nat) -> 19 | > (x : X t ** (So (reachable x), So (viable n x))) -> 20 | > Blt (nX t n) 21 | 22 | > xedni : (n : Nat) -> 23 | > Blt (nX t n) -> 24 | > (x : X t ** (So (reachable x), So (viable n x))) 25 | 26 | 27 | -------------------------------------------------------------------------------- /frameworks/11-14/EffectException.lidr: -------------------------------------------------------------------------------- 1 | > module EffectException 2 | 3 | 4 | > import Effects 5 | > import Effect.Exception 6 | > import Data.So 7 | 8 | > import NatProperties 9 | > import BoundedNat.Blt 10 | 11 | 12 | > %default total 13 | 14 | 15 | > ||| Parses a string for a Nat 16 | > parseNat : String -> { [EXCEPTION String] } Eff Nat 17 | > parseNat str 18 | > = if all (\x => isDigit x) (unpack str) 19 | > then pure (cast {to = Nat} (cast {to = Int} str)) 20 | > else raise "Not a Nat!" 21 | 22 | 23 | > ||| Parses a string for a bounded Nat 24 | > parseBlt : (b : Nat) -> String -> { [EXCEPTION String] } Eff (Blt b) 25 | > parseBlt b str 26 | > = if all (\x => isDigit x) (unpack str) 27 | > then let n = cast {to = Nat} (cast {to = Int} str) in 28 | > case (n < b) of 29 | > True => pure (MkSigma n (believe_me Oh)) 30 | > False => raise "Out of bound!" 31 | > else raise "Not a Nat!" 32 | 33 | 34 | > ||| Parses a string for an Int 35 | > parseInt : String -> { [EXCEPTION String] } Eff Int 36 | > parseInt str 37 | > = if all (\x => isDigit x || x == '-') (unpack str) 38 | > then pure (cast {to = Int} str) 39 | > else raise "Not an Int!" 40 | 41 | 42 | -- Local Variables: 43 | -- idris-packages: ("effects") 44 | -- End: 45 | -------------------------------------------------------------------------------- /frameworks/11-14/EffectStdIO.lidr: -------------------------------------------------------------------------------- 1 | > module EffectStdIO 2 | 3 | > import Effects 4 | > import Effect.StdIO 5 | > import Effect.Exception 6 | > import Data.So 7 | 8 | > import EffectException 9 | > import BoundedNat.Blt 10 | 11 | 12 | > %default total 13 | 14 | 15 | > ||| 16 | > %assert_total -- termination not required 17 | > getNat : { [STDIO] } Eff Nat 18 | > getNat = 19 | > do putStr (" Nat: " ) 20 | > case the (Either String Nat) (run (parseNat (trim !getStr))) of 21 | > Left err => do putStr (err ++ "\n") 22 | > getNat 23 | > Right n => do putStr "thanks!\n" 24 | > pure n 25 | 26 | 27 | > ||| 28 | > %assert_total -- termination not required 29 | > getBlt : (b : Nat) -> { [STDIO] } Eff (Blt b) 30 | > getBlt b = 31 | > do putStr (" Nat, < " ++ cast {from = Int} (cast b) ++ ": " ) 32 | > case the (Either String (Blt b)) (run (parseBlt b (trim !getStr))) of 33 | > Left err => do putStr (err ++ "\n") 34 | > getBlt b 35 | > Right n => do putStr "thanks!\n" 36 | > pure n 37 | 38 | 39 | -- Local Variables: 40 | -- idris-packages: ("effects") 41 | -- End: 42 | -------------------------------------------------------------------------------- /frameworks/11-14/Exists/Ops.lidr: -------------------------------------------------------------------------------- 1 | > module Ops 2 | 3 | > %default total 4 | 5 | 6 | > outl : {a : Type} -> {P : a -> Type} -> Sigma a P -> a 7 | > outl = getWitness 8 | 9 | > outr : {a : Type} -> {P : a -> Type} -> (s : Sigma a P) -> P (getWitness s) 10 | > outr = getProof -------------------------------------------------------------------------------- /frameworks/11-14/Float/Float.lidr: -------------------------------------------------------------------------------- 1 | > module Float 2 | 3 | 4 | > import Data.So 5 | 6 | > import Exists.Ops 7 | 8 | 9 | > %default total 10 | 11 | 12 | > ||| Non negative |Float|s 13 | > data NonNegFloat : Type where 14 | > MkNonNegFloat : (x : Float) -> So (x >= 0.0) -> NonNegFloat 15 | 16 | > instance Cast NonNegFloat Float where 17 | > cast (MkNonNegFloat x _) = x 18 | 19 | 20 | > ||| |Float|s in [a,b] 21 | > data GeLeFloat : Float -> Float -> Type where 22 | > MkGeLeFloat : {a : Float} -> {b : Float} -> 23 | > (x : Float) -> So (a <= x) -> So (x <= b) -> GeLeFloat a b 24 | 25 | > using (a, b : Float) 26 | > instance Cast (GeLeFloat a b) Float where 27 | > cast (MkGeLeFloat x _ _) = x 28 | 29 | 30 | > ||| 31 | > data GeFloat : Float -> Type where 32 | > MkGeFloat : {a : Float} -> (x : Float) -> So (a <= x) -> GeFloat a 33 | 34 | > using (a : Float) 35 | > instance Cast (GeFloat a) Float where 36 | > cast (MkGeFloat x _) = x 37 | 38 | 39 | > ||| 40 | > data LeFloat : Float -> Type where 41 | > MkLeFloat : {a : Float} -> (x : Float) -> So (x <= a) -> LeFloat a 42 | 43 | > using (a : Float) 44 | > instance Cast (LeFloat a) Float where 45 | > cast (MkLeFloat x _) = x 46 | 47 | 48 | 49 | > using (p : Float -> Type) 50 | > instance Show (x : Float ** p x) where 51 | > show (x ** _) = show x 52 | 53 | > using (p : Float -> Type) 54 | > instance Eq (x : Float ** p x) where 55 | > (==) (x ** _) (y ** _) = x == y 56 | 57 | 58 | 59 | 60 | 61 | -------------------------------------------------------------------------------- /frameworks/11-14/Float/Postulates.lidr: -------------------------------------------------------------------------------- 1 | > module Postulates 2 | 3 | > import Data.So 4 | 5 | > import Rel.Syntax 6 | 7 | 8 | > postulate sub_Float_eqeq_lte : sub Float (==) (<=) 9 | 10 | > postulate sub_Float_lt_lte : sub Float (<) (<=) 11 | 12 | > postulate reflexive_Float_eqeq : reflexive Float (==) 13 | 14 | > postulate symmetric_Float_eqeq : symmetric Float (==) 15 | 16 | > postulate transitive_Float_lte : transitive Float (<=) 17 | 18 | > postulate monotone_Float_plus_lte : monotone Float (+) (<=) 19 | 20 | > postulate monotone'_Float_plus_lte : monotone' Float (+) (<=) 21 | 22 | 23 | 24 | 25 | 26 | -------------------------------------------------------------------------------- /frameworks/11-14/Float/Properties.lidr: -------------------------------------------------------------------------------- 1 | > module Properties 2 | 3 | > import Data.So 4 | 5 | > import Rel.Syntax 6 | > import Float.Postulates 7 | 8 | > %default total 9 | 10 | > reflexive_Float_lte : reflexive Float (<=) 11 | > reflexive_Float_lte x = sub_Float_eqeq_lte (reflexive_Float_eqeq x) 12 | 13 | -------------------------------------------------------------------------------- /frameworks/11-14/Fun/Fun.lidr: -------------------------------------------------------------------------------- 1 | > module Fun 2 | 3 | > {- 4 | > HasUnitSumOn : (Functor t, Foldable t, Num b) => (f : a -> b) -> (ta : t a) -> Type 5 | > HasUnitSumOn f ta = sum (map f ta) = 1 6 | > -} 7 | 8 | > HasUnitSumOn : (Functor t, Foldable t) => (f : a -> Float) -> (ta : t a) -> Type 9 | > HasUnitSumOn f ta = sum (map f ta) = 1 10 | 11 | -------------------------------------------------------------------------------- /frameworks/11-14/Logic/Ops.lidr: -------------------------------------------------------------------------------- 1 | > module Ops 2 | 3 | Basic propositional connectives at |Type|-level instead of |Bool|. 4 | 5 | > Not : (A : Type) -> Type 6 | > Not A = A -> _|_ 7 | 8 | > or : (a -> Bool) -> (a -> Bool) -> (a -> Bool) 9 | > or p q a = p a || q a -------------------------------------------------------------------------------- /frameworks/11-14/Logic/Postulates.lidr: -------------------------------------------------------------------------------- 1 | > module Postulates 2 | 3 | > -- import Logic.Ops 4 | 5 | We should only need to postulate classical properties. 6 | 7 | > doubleNeg : {A : Type} -> Not (Not A) -> A -- cannot postulate??? 8 | > doubleNeg nna = believe_me "Error: evaluated doubleNeg!" 9 | 10 | 11 | 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /frameworks/11-14/Makefile: -------------------------------------------------------------------------------- 1 | IDRIS = idris 2 | IDRISFLAGS = +RTS -K32000000 -RTS -p contrib -p effects 3 | 4 | all: 5 | find . -name '*.lidr' | xargs -n 1 ${IDRIS} ${IDRISFLAGS} -i .. --check 6 | 7 | example: DynamicProgramming/S1309_Example2.lidr 8 | ${IDRIS} ${IDRISFLAGS} DynamicProgramming/S1309_Example2.lidr -o example 9 | 10 | small_example: DynamicProgrammingSmall/S1309_Example2.lidr 11 | ${IDRIS} ${IDRISFLAGS} DynamicProgrammingSmall/S1309_Example2.lidr -o small_example 12 | 13 | profexample: DynamicProgramming/S1309_Example2.lidr 14 | IDRIS_CFLAGS="-pg" ${IDRIS} ${IDRISFLAGS} DynamicProgramming/S1309_Example2.lidr -o profexample 15 | 16 | run: example 17 | echo "3\n1" | ./example 18 | 19 | profile: profexample 20 | echo "3\n1" | ./profexample 21 | gprof profexample gmon.out > profile.txt 22 | 23 | examples: DynamicProgramming/S1106_Knapsack.lidr \ 24 | DynamicProgramming/S1206_Example2.lidr 25 | ${IDRIS} ${IDRISFLAGS} DynamicProgramming/S1106_Knapsack.lidr -o S1106_Knapsack.exe 26 | ${IDRIS} ${IDRISFLAGS} DynamicProgramming/S1206_Example2.lidr -o S1206_Example2.exe 27 | 28 | clean: 29 | -rm example 30 | -rm small_example 31 | -rm S1106_Knapsack.exe 32 | -rm S1206_Example2.exe 33 | -find . -name '*.ibc' -delete 34 | -------------------------------------------------------------------------------- /frameworks/11-14/Nat/Ops.lidr: -------------------------------------------------------------------------------- 1 | > module Ops 2 | 3 | > toFloatNat : Nat -> Float 4 | > toFloatNat Z = 0.0 5 | > toFloatNat (S k) = 1.0 + toFloatNat k 6 | 7 | > instance Cast Nat Float where 8 | > cast = toFloatNat -------------------------------------------------------------------------------- /frameworks/11-14/Nat/Properties.lidr: -------------------------------------------------------------------------------- 1 | > module Properties 2 | 3 | > import Data.So 4 | 5 | > import Logic.Properties 6 | 7 | > %default total 8 | 9 | > -- Zero is not a successor 10 | > ZnotS : Z = S n -> Void 11 | > ZnotS Refl impossible 12 | 13 | > -- A successor is not zero 14 | > SnotZ : S n = Z -> Void 15 | > SnotZ Refl impossible 16 | 17 | > ltZ_bot : So (n < Z) -> Void 18 | > ltZ_bot {n = Z} nltZ = soFalseElim nltZ 19 | > ltZ_bot {n = S m} nltZ = soFalseElim nltZ 20 | 21 | -------------------------------------------------------------------------------- /frameworks/11-14/Preorder.lidr: -------------------------------------------------------------------------------- 1 | > module Preorder 2 | 3 | 4 | > %default total 5 | 6 | 7 | > ||| Preorder 8 | > data Preorder : Type -> Type where 9 | > MkPreorder : {A : Type} -> 10 | > (R : A -> A -> Type) -> 11 | > (reflexive : (x : A) -> R x x) -> 12 | > (transitive : (x : A) -> (y : A) -> (z : A) -> R x y -> R y z -> R x z) -> 13 | > Preorder A 14 | 15 | 16 | > {- 17 | 18 | > ||| Preorder on t 19 | > class Preorder t where 20 | > total C : t -> t -> Type 21 | > total reflexive : (x : t) -> C x x 22 | > total transitive : (x : t) -> (y : t) -> (z : t) -> C x y -> C y z -> C x z 23 | 24 | 25 | > ||| Total preorder on t 26 | > class (Preorder t) => TotalPreorder t where 27 | > total totalPre : (x : t) -> (y : t) -> Either (C x y) (C y x) 28 | 29 | > -} 30 | 31 | 32 | > {- 33 | 34 | > ||| Preorder on t 35 | > class Preorder (t : Type) (po : t -> t -> Type) where 36 | > total reflexive : (x : t) -> po x x 37 | > total transitive : (x : t) -> (y : t) -> (z : t) -> po x y -> po y z -> po x z 38 | 39 | > ||| Preorders on |t1| induce preorders on |(t1, t2)| 40 | > instance Preorder t1 po => Preorder (t1, t2) (\ x => \ y => po (fst x) (fst y)) where 41 | > reflexive x = reflexive (fst x) 42 | > transitive x y z xy yz = transitive (fst x) (fst y) (fst z) xy yz 43 | 44 | > -} 45 | 46 | 47 | > {- 48 | 49 | > class (Preorder t to) => Preordered t (to : t -> t -> Type) | t where 50 | > total preorder : (a : t) -> (b : t) -> Either (to a b) (to b a) 51 | 52 | > -} 53 | -------------------------------------------------------------------------------- /frameworks/11-14/Rel/DecEq.lidr: -------------------------------------------------------------------------------- 1 | > module DecEq 2 | 3 | 4 | > %default total 5 | 6 | 7 | > class DecEq alpha where 8 | > dec_eq : (a : alpha) -> 9 | > (a' : alpha) -> 10 | > Either (a = a') (Not (a = a')) 11 | 12 | -------------------------------------------------------------------------------- /frameworks/11-14/Rel/EqEq.lidr: -------------------------------------------------------------------------------- 1 | > module EqEq 2 | 3 | 4 | > class Eq alpha => EqEq alpha where 5 | -------------------------------------------------------------------------------- /frameworks/11-14/Rel/Postulates.lidr: -------------------------------------------------------------------------------- 1 | > module Postulates 2 | 3 | 4 | > import Rel.Syntax 5 | 6 | 7 | 8 | 9 | -------------------------------------------------------------------------------- /frameworks/11-14/Rel/Properties.lidr: -------------------------------------------------------------------------------- 1 | > module Properties 2 | 3 | 4 | > import Rel.Syntax 5 | > import Rel.Postulates 6 | 7 | > eqTrans : {A : Type} -> {a1 : A} -> {a2 : A} -> {a3 : A} -> 8 | > a1 = a2 -> a2 = a3 -> a1 = a3 9 | > eqTrans {a1} {a2} {a3} p12 p23 = replace -- {P = \ a => a1 = a} 10 | > p23 p12 11 | 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /frameworks/11-14/Rel/ReflDecEq.lidr: -------------------------------------------------------------------------------- 1 | > module ReflDecEq 2 | 3 | > import Rel.DecEq 4 | 5 | 6 | > %default total 7 | 8 | 9 | > class DecEq.DecEq alpha => ReflDecEq alpha where 10 | > reflexive_dec_eq : (a : alpha) -> dec_eq a a = Left Refl 11 | -------------------------------------------------------------------------------- /frameworks/11-14/Rel/ReflEqEq.lidr: -------------------------------------------------------------------------------- 1 | > module ReflEqEq 2 | 3 | > import Data.So 4 | 5 | > import Logic.Properties 6 | > import Rel.EqEq 7 | 8 | 9 | > class EqEq alpha => ReflEqEq alpha where 10 | > reflexive_eqeq : (a : alpha) -> So (a == a) 11 | > Reflexive_eqeq : (a : alpha) -> (a == a) = True 12 | > Reflexive_eqeq a = soElim C Refl (a == a) (reflexive_eqeq a) where 13 | > C : (b : Bool) -> So b -> Type 14 | > C b s = b = True 15 | -------------------------------------------------------------------------------- /frameworks/11-14/Rel/Syntax.lidr: -------------------------------------------------------------------------------- 1 | > module Syntax 2 | 3 | 4 | > syntax reflexive [alpha] [r] = (a : alpha) -> So (r a a) 5 | 6 | > syntax symmetric [alpha] [r] = {a1 : alpha} -> 7 | > {a2 : alpha} -> 8 | > So (r a1 a2) -> 9 | > So (r a2 a1) 10 | 11 | > syntax transitive [alpha] [r] = {a1 : alpha} -> 12 | > {a2 : alpha} -> 13 | > {a3 : alpha} -> 14 | > So (r a1 a2) -> 15 | > So (r a2 a3) -> 16 | > So (r a1 a3) 17 | 18 | > syntax sub [alpha] [r1] [r2] = {a1 : alpha} -> 19 | > {a2 : alpha} -> 20 | > So (r1 a1 a2) -> 21 | > So (r2 a1 a2) 22 | 23 | > syntax monotone [alpha] [op2] [r] = {a1 : alpha} -> 24 | > {a2 : alpha} -> 25 | > (a3 : alpha) -> 26 | > So (r a1 a2) -> 27 | > So (r (op2 a3 a1) (op2 a3 a2)) 28 | 29 | > syntax monotone' [alpha] [op2] [r] = {a1 : alpha} -> 30 | > {a2 : alpha} -> 31 | > (a3 : alpha) -> 32 | > So (r (op2 a3 a1) (op2 a3 a2)) -> 33 | > So (r a1 a2) 34 | -------------------------------------------------------------------------------- /frameworks/11-14/TotalPreorder.lidr: -------------------------------------------------------------------------------- 1 | > module TotalPreorder 2 | 3 | > import Preorder 4 | 5 | > %default total 6 | 7 | 8 | > ||| TotalPreorder 9 | > data TotalPreorder : Type -> Type where 10 | > MkTotalPreorder : {A : Type} -> 11 | > (R : A -> A -> Type) -> 12 | > (reflexive : (x : A) -> R x x) -> 13 | > (transitive : (x : A) -> (y : A) -> (z : A) -> R x y -> R y z -> R x z) -> 14 | > (totalPre : (x : A) -> (y : A) -> Either (R x y) (R y x)) -> 15 | > TotalPreorder A 16 | -------------------------------------------------------------------------------- /frameworks/11-14/Util/Opt.lidr: -------------------------------------------------------------------------------- 1 | > module Opt 2 | 3 | > import Data.So 4 | > import Data.Vect 5 | 6 | > import Logic.Properties 7 | 8 | > %default total 9 | 10 | > max2' : (alpha, Float) -> 11 | > (alpha, Float) -> 12 | > (alpha, Float) 13 | > max2' a b = if (snd a < snd b) then b else a 14 | 15 | > max3' : (alpha, Float) -> 16 | > (alpha, Float) -> 17 | > (alpha, Float) -> 18 | > (alpha, Float) 19 | > max3' a b c = max2' a (max2' b c) 20 | 21 | > maxP : Vect (S n) (alpha, Float) -> (alpha, Float) 22 | > maxP (af :: afs) = foldr max2' af afs 23 | 24 | > maxP' : (Vect n (alpha, Float), So (Z < n)) -> (alpha, Float) 25 | > maxP' {n = Z} (Nil, ZltZ) = soFalseElim ZltZ 26 | > maxP' {n = S n} ((af :: afs), _) = foldr max2' af afs 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /frameworks/11-14/Util/Util.lidr: -------------------------------------------------------------------------------- 1 | > module Util 2 | 3 | 4 | > pair : (a -> b, a -> c) -> a -> (b, c) 5 | > pair (f, g) x = (f x, g x) 6 | 7 | 8 | > didi : (a -> b, c -> d) -> (a, c) -> (b, d) 9 | > didi (f, g) (a, c) = (f a, g c) 10 | -------------------------------------------------------------------------------- /frameworks/14-/.gitignore: -------------------------------------------------------------------------------- 1 | example 2 | -------------------------------------------------------------------------------- /frameworks/14-/BoundedNat.lidr: -------------------------------------------------------------------------------- 1 | > module BoundedNat 2 | 3 | > import Sigma 4 | 5 | > %default total 6 | 7 | > %access public export 8 | 9 | 10 | > ||| Natural numbers bounded by LT 11 | > LTB : Nat -> Type 12 | > LTB b = Sigma Nat (\ n => LT n b) 13 | 14 | > ||| Natural numbers bounded by LTE 15 | > LTEB : Nat -> Type 16 | > LTEB b = Sigma Nat (\ n => LTE n b) 17 | -------------------------------------------------------------------------------- /frameworks/14-/BoundedNatOperations.lidr: -------------------------------------------------------------------------------- 1 | > module BoundedNatOperations 2 | 3 | > import Data.Fin 4 | > import Data.Vect 5 | 6 | > import BoundedNat 7 | > import FinProperties 8 | > import NatLTProperties 9 | > import Sigma 10 | > import PairsOperations 11 | 12 | > %default total 13 | > %access public export 14 | 15 | 16 | > ||| Mapping bounded |Nat|s to |Fin|s 17 | > toFin : {b : Nat} -> LTB b -> Fin b 18 | > toFin {b = Z} (MkSigma _ nLT0 ) = void (succNotLTEzero nLT0) 19 | > toFin {b = S m} (MkSigma Z _ ) = FZ 20 | > toFin {b = S m} (MkSigma (S n) (LTESucc prf)) = FS (toFin (MkSigma n prf)) 21 | 22 | > ||| Mapping |Fin|s to bounded |Nat|s 23 | > fromFin : {b : Nat} -> Fin b -> LTB b 24 | > fromFin k = MkSigma (finToNat k) (finToNatLemma k) 25 | 26 | > ||| 27 | > toVect : {b : Nat} -> {A : Type} -> (LTB b -> A) -> Vect b A 28 | > toVect {b = Z} _ = Nil 29 | > toVect {b = S b'} {A} f = (f (MkSigma Z (ltZS b'))) :: toVect f' where 30 | > f' : LTB b' -> A 31 | > f' (MkSigma k q) = f (MkSigma (S k) (LTESucc q)) 32 | -------------------------------------------------------------------------------- /frameworks/14-/Decidable.lidr: -------------------------------------------------------------------------------- 1 | > module Decidable 2 | 3 | 4 | > %default total 5 | 6 | > %access public export 7 | 8 | 9 | > Dec0 : Type -> Type 10 | > Dec0 = Dec 11 | 12 | > Dec1 : {A : Type} -> (P : A -> Type) -> Type 13 | > Dec1 {A} P = (a : A) -> Dec0 (P a) 14 | 15 | > DecEq0 : Type -> Type 16 | > DecEq0 A = (a1 : A) -> (a2 : A) -> Dec (a1 = a2) 17 | 18 | > DecEq1 : {A : Type} -> (P : A -> Type) -> Type 19 | > DecEq1 {A} P = (a : A) -> DecEq0 (P a) 20 | -------------------------------------------------------------------------------- /frameworks/14-/DecidableProperties.lidr: -------------------------------------------------------------------------------- 1 | > module DecidableProperties 2 | 3 | 4 | > import Decidable 5 | 6 | 7 | > %default total 8 | 9 | > %access public export 10 | 11 | 12 | > ||| If |P| is decidable, |Not P| is decidable 13 | > decNot : {P : Type} -> Dec P -> Dec (Not P) 14 | > decNot {P} (Yes prf) = No contra where 15 | > contra : Not P -> Void 16 | > contra np = np prf 17 | > decNot {P} (No contra) = Yes contra 18 | > %freeze decNot -- frozen 19 | 20 | 21 | > ||| If |P| and |Q| are decidable, |(P , Q)| is decidable 22 | > decPair : {P, Q : Type} -> Dec P -> Dec Q -> Dec (P , Q) 23 | > decPair (Yes p) (Yes q) = Yes (p , q) 24 | > decPair (Yes p) (No nq) = No (\ pq => nq (snd pq)) 25 | > decPair (No np) (Yes q) = No (\ pq => np (fst pq)) 26 | > decPair (No np) (No nq) = No (\ pq => np (fst pq)) 27 | > %freeze decPair -- frozen 28 | 29 | 30 | > ||| If |P| and |Q| are decidable, |Either P Q| is decidable 31 | > decEither : {P, Q : Type} -> Dec P -> Dec Q -> Dec (Either P Q) 32 | > decEither (Yes p) _ = Yes (Left p) 33 | > decEither (No np) (Yes q) = Yes (Right q) 34 | > decEither {P} {Q} (No np) (No nq) = No contra where 35 | > contra : Either P Q -> Void 36 | > contra (Left p) = np p 37 | > contra (Right q) = nq q 38 | > %freeze decEither -- frozen 39 | -------------------------------------------------------------------------------- /frameworks/14-/EffectException.lidr: -------------------------------------------------------------------------------- 1 | > module EffectException 2 | 3 | 4 | > import Effects 5 | > import Effect.Exception 6 | 7 | > import NatLTProperties 8 | > import BoundedNat 9 | > import Sigma 10 | > import PairsOperations 11 | 12 | 13 | > %default total 14 | 15 | > %access public export 16 | 17 | 18 | > ||| Parses a string for a Nat 19 | > parseNat : String -> { [EXCEPTION String] } Eff Nat 20 | > parseNat str 21 | > = if all (\x => isDigit x) (unpack str) 22 | > then pure (cast {to = Nat} (cast {to = Int} str)) 23 | > else raise "Not a Nat!" 24 | 25 | 26 | > ||| Parses a string for a bounded Nat 27 | > parseLTB : (b : Nat) -> String -> { [EXCEPTION String] } Eff (LTB b) 28 | > {- 29 | > parseLTB b str 30 | > = if all (\x => isDigit x) (unpack str) 31 | > then let n = cast {to = Nat} (cast {to = Int} str) in 32 | > case (decLT n b) of 33 | > (Yes p) => pure (MkSigma n p) 34 | > (No _) => raise "Out of bound!" 35 | > else raise "Not a Nat!" 36 | > -} 37 | > parseLTB b str 38 | > = if all (\x => isDigit x) (unpack str) 39 | > then let m = cast {to = Nat} (cast {to = Int} str) in 40 | > case (decLT m b) of 41 | > (Yes p) => pure (MkSigma m p) 42 | > (No _) => raise "Out of bound!" 43 | > else raise "Not a Nat!" 44 | 45 | 46 | > ||| Parses a string for an Int 47 | > parseInt : String -> { [EXCEPTION String] } Eff Int 48 | > parseInt str 49 | > = if all (\x => isDigit x || x == '-') (unpack str) 50 | > then pure (cast {to = Int} str) 51 | > else raise "Not an Int!" 52 | 53 | 54 | -- Local Variables: 55 | -- idris-packages: ("effects") 56 | -- End: 57 | -------------------------------------------------------------------------------- /frameworks/14-/EffectStdIO.lidr: -------------------------------------------------------------------------------- 1 | > module EffectStdIO 2 | 3 | > import Effects 4 | > import Effect.StdIO 5 | > import Effect.Exception 6 | 7 | > import EffectException 8 | > import BoundedNat 9 | > import Sigma 10 | > import PairsOperations 11 | 12 | > %default total 13 | 14 | > %access public export 15 | 16 | 17 | > ||| 18 | > %assert_total -- termination not required 19 | > getNat : { [STDIO] } Eff Nat 20 | > getNat = 21 | > do putStr (" Nat: " ) 22 | > case the (Either String Nat) (run (parseNat (trim !getStr))) of 23 | > Left err => do putStr (err ++ "\n") 24 | > getNat 25 | > Right n => do putStr "thanks!\n" 26 | > pure n 27 | 28 | 29 | > ||| 30 | > %assert_total -- termination not required 31 | > getLTB : (b : Nat) -> { [STDIO] } Eff (LTB b) 32 | > getLTB b = 33 | > do putStr (" Nat, < " ++ cast {from = Int} (cast b) ++ ": " ) 34 | > case the (Either String (LTB b)) (run (parseLTB b (trim !getStr))) of 35 | > Left err => do putStr (err ++ "\n") 36 | > getLTB b 37 | > Right n => do putStr "thanks!\n" 38 | > pure n 39 | 40 | 41 | -- Local Variables: 42 | -- idris-packages: ("effects") 43 | -- End: 44 | -------------------------------------------------------------------------------- /frameworks/14-/EqualityProperties.lidr: -------------------------------------------------------------------------------- 1 | > module EqualityProperties 2 | 3 | 4 | > import Unique 5 | 6 | 7 | > %default total 8 | 9 | > %access public export 10 | 11 | 12 | > ||| Equality is unique 13 | > uniqueEq : {A : Type} -> (a1 : A) -> (a2 : A) -> Unique (a1 = a2) 14 | > uniqueEq a a Refl Refl = Refl 15 | > %freeze uniqueEq -- frozen 16 | 17 | -------------------------------------------------------------------------------- /frameworks/14-/ExistsOperations.lidr: -------------------------------------------------------------------------------- 1 | > module ExistsOperations 2 | 3 | 4 | > import PairsOperations 5 | 6 | 7 | > %default total 8 | 9 | > %access public export 10 | 11 | 12 | > ||| 13 | > outl : {A : Type} -> {P : A -> Type} -> Exists {a = A} P -> A 14 | > outl = getWitness 15 | 16 | 17 | > ||| 18 | > outr : {A : Type} -> {P : A -> Type} -> (s : Exists {a = A} P) -> P (outl s) 19 | > outr = getProof 20 | 21 | 22 | -------------------------------------------------------------------------------- /frameworks/14-/FinOperations.lidr: -------------------------------------------------------------------------------- 1 | > module FinOperations 2 | 3 | > import Data.Fin 4 | > import Data.Vect 5 | 6 | 7 | > %default total 8 | 9 | > %access public export 10 | 11 | 12 | > ||| 'Tail' of a finite function 13 | > tail : {A : Type} -> {n : Nat} -> 14 | > (Fin (S n) -> A) -> (Fin n -> A) 15 | > -- tail f k = f (FS k) 16 | > tail f = f . FS 17 | 18 | 19 | > ||| Maps a finite function to a vector 20 | > toVect : {A : Type} -> {n : Nat} -> 21 | > (Fin n -> A) -> Vect n A 22 | > toVect {n = Z} _ = Nil 23 | > toVect {n = S m} f = (f FZ) :: (toVect (tail f)) 24 | > -- toVect f = map f range 25 | 26 | > ||| Sum of the values of a finite function 27 | > sum : {n : Nat} -> (Fin n -> Nat) -> Nat 28 | > sum {n = Z} f = Z 29 | > sum {n = S m} f = f FZ + sum (tail f) 30 | -------------------------------------------------------------------------------- /frameworks/14-/Finite.lidr: -------------------------------------------------------------------------------- 1 | > module Finite 2 | 3 | > import Prelude.Maybe 4 | > import Data.Fin 5 | > import Control.Isomorphism 6 | > -- import EmbProj 7 | 8 | > import Sigma 9 | 10 | > %default total 11 | 12 | > %access public export 13 | 14 | 15 | > ||| Notion of finiteness for types 16 | > Finite : Type -> Type 17 | > Finite A = Sigma Nat (\ n => Iso A (Fin n)) 18 | 19 | > Finite0 : Type -> Type 20 | > Finite0 = Finite 21 | 22 | > Finite1 : {A : Type} -> (P : A -> Type) -> Type 23 | > Finite1 {A} P = (a : A) -> Finite0 (P a) 24 | 25 | > {- 26 | 27 | This definition requires an exact cardinality |n| which may be 28 | difficult to compute. But it is enough to know a finite bound, so an 29 | alternative definition which may be more convenient is the following: 30 | 31 | > FiniteSub : Type -> Type 32 | > FiniteSub A = Exists (\ n => EmbProj A (Fin n)) 33 | 34 | ---------------- 35 | 36 | > FiniteN : Nat -> Type -> Type 37 | > FiniteN n A = Iso A (Fin n) 38 | 39 | > ---} 40 | -------------------------------------------------------------------------------- /frameworks/14-/FiniteSubType.lidr: -------------------------------------------------------------------------------- 1 | > module FiniteSubType 2 | 3 | > import Finite 4 | > import SubType 5 | > import Unique 6 | 7 | 8 | > %default total 9 | 10 | > %access public export 11 | 12 | 13 | > FiniteSubType : (A : Type) -> (P : A -> Type) -> Unique1 P -> Type 14 | > FiniteSubType A P uP = Finite (SubType A P uP) 15 | -------------------------------------------------------------------------------- /frameworks/14-/FiniteSubTypeOperations.lidr: -------------------------------------------------------------------------------- 1 | > module FiniteSubTypeOperations 2 | 3 | > import FiniteSubType 4 | 5 | > %default total 6 | 7 | > %access public export 8 | -------------------------------------------------------------------------------- /frameworks/14-/FiniteSubTypeProperties.lidr: -------------------------------------------------------------------------------- 1 | > module FiniteSubTypeProperties 2 | 3 | > import Data.Fin 4 | > import Data.Vect 5 | > import Control.Isomorphism 6 | 7 | > import SubType 8 | > import Finite 9 | > import FiniteSubType 10 | > import Decidable 11 | > import Unique 12 | > import UniqueProperties 13 | > import SigmaProperties 14 | 15 | 16 | > %default total 17 | 18 | > %access public export 19 | 20 | 21 | > ||| For decidable and unique predicates, subtypes of finite types are finite 22 | > ||| (proof suggested my Matteo Acerbi) 23 | > finiteSubTypeLemma0 : {A : Type} -> {P : A -> Type} -> 24 | > Finite A -> Dec1 P -> (uP : Unique1 P) -> 25 | > Finite (SubType A P uP) 26 | > finiteSubTypeLemma0 fA dP uP = finiteSigmaLemma0 fA (\ a => decUniqueFiniteLemma (dP a) (uP a)) 27 | > %freeze finiteSubTypeLemma0 -- frozen 28 | 29 | -------------------------------------------------------------------------------- /frameworks/14-/Fraction.lidr: -------------------------------------------------------------------------------- 1 | > module Fraction 2 | 3 | > import PNat 4 | 5 | > %default total 6 | > %access public export 7 | 8 | 9 | > ||| Fraction representation 10 | > Fraction : Type 11 | > Fraction = (Nat, PNat) 12 | -------------------------------------------------------------------------------- /frameworks/14-/FractionBasicOperations.lidr: -------------------------------------------------------------------------------- 1 | > module FractionBasicOperations 2 | 3 | > import Fraction 4 | > import PNat 5 | > import PNatOperations 6 | > import NatPositive 7 | 8 | > %default total 9 | > %access public export 10 | 11 | 12 | > ||| The numerator of a fraction 13 | > num : Fraction -> Nat 14 | > num = fst 15 | 16 | 17 | > ||| The denominator of a fraction 18 | > den : Fraction -> Nat 19 | > den = toNat . snd 20 | 21 | 22 | > ||| Every natural number is a fraction 23 | > fromNat : Nat -> Fraction 24 | > fromNat n = (n, Element (S Z) MkPositive) 25 | 26 | 27 | > ||| Fraction addition 28 | > plus : Fraction -> Fraction -> Fraction 29 | > plus (n1, d1) (n2, d2) = (n1 * (toNat d2) + n2 * (toNat d1), d1 * d2) 30 | 31 | 32 | > ||| Fraction multiplication 33 | > mult : Fraction -> Fraction -> Fraction 34 | > mult (n1, d1) (n2, d2) = (n1 * n2, d1 * d2) 35 | 36 | 37 | > ||| Fraction upscaling 38 | > upscale : Fraction -> PNat -> Fraction 39 | > upscale (m, d) e = (m * (toNat e), d * e) 40 | 41 | 42 | 43 | 44 | -------------------------------------------------------------------------------- /frameworks/14-/FractionNormal.lidr: -------------------------------------------------------------------------------- 1 | > module FractionNormal 2 | 3 | 4 | > import Fraction 5 | > import FractionBasicOperations 6 | > import NatCoprime 7 | > import Unique 8 | > import NatGCD 9 | > import NatGCDEuclid 10 | > import PNat 11 | > import NatPositive 12 | > import PairsOperations 13 | 14 | 15 | > %default total 16 | 17 | > %access public export 18 | 19 | 20 | > ||| 21 | > data Normal : Fraction -> Type where 22 | > MkNormal : {x : Fraction} -> Coprime (num x) (den x) -> Normal x 23 | 24 | > ||| 25 | > NormalUnique : {x : Fraction} -> Unique (Normal x) 26 | > NormalUnique {x} (MkNormal p) (MkNormal q) = cong (CoprimeUnique p q) 27 | 28 | -------------------------------------------------------------------------------- /frameworks/14-/FractionTest.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import Fraction 4 | > import FractionOperations 5 | > import FractionProperties 6 | > import PNat 7 | > import PNatOperations 8 | > import PNatProperties 9 | 10 | > %default total 11 | 12 | 13 | > x : Fraction 14 | > x = (2067, fromNat 616 (LTESucc LTEZero)) 15 | > %freeze x 16 | 17 | > y : Fraction 18 | > y = (32, fromNat 11 (LTESucc LTEZero)) 19 | > %freeze x 20 | 21 | > z : Fraction 22 | > z = x + y 23 | 24 | > main : IO () 25 | > main = do putStrLn ("x = " ++ show x) 26 | > putStrLn ("y = " ++ show y) 27 | > putStrLn ("z = " ++ show z) 28 | > putStrLn ("z = " ++ show (normalize z)) 29 | 30 | -------------------------------------------------------------------------------- /frameworks/14-/FunOperations.lidr: -------------------------------------------------------------------------------- 1 | > module FunOperations 2 | 3 | > import Data.So 4 | 5 | 6 | > %default total 7 | 8 | > %access public export 9 | 10 | 11 | > ||| 12 | > pair : (a -> b, a -> c) -> a -> (b, c) 13 | > pair (f, g) x = (f x, g x) 14 | 15 | 16 | > ||| 17 | > cross : (a -> c) -> (b -> d) -> (a, b) -> (c, d) 18 | > cross f g (x, y) = (f x, g y) 19 | 20 | 21 | > ||| 22 | > modifyFun : {a : Type} -> {b : Type} -> (Eq a) => 23 | > (a -> b) -> a -> b -> (a -> b) 24 | > modifyFun f a b a' = if a' == a then b else f a' 25 | 26 | > {- 27 | 28 | > soTrue : So b -> b = True 29 | 30 | > reflexive_eqeq : (Eq a) => (x : a) -> So (x == x) 31 | 32 | > modifyFunLemma : {a : Type} -> {b : Type} -> (Eq a) => 33 | > (f : a -> b) -> (x : a) -> (y : b) -> 34 | > modifyFun f x y x = y 35 | > modifyFunLemma f x y = replace {P = \ z => ifThenElse (x == x) y (f x) = ifThenElse z y (f x)} 36 | > (soTrue (reflexive_eqeq x)) 37 | > Refl 38 | 39 | > -} 40 | 41 | -------------------------------------------------------------------------------- /frameworks/14-/IdentityOperations.lidr: -------------------------------------------------------------------------------- 1 | > module IdentityOperations 2 | 3 | 4 | > import Control.Monad.Identity 5 | 6 | 7 | > import Sigma 8 | 9 | 10 | > %default total 11 | > %access public export 12 | > %auto_implicits on 13 | 14 | 15 | > ||| 16 | > unwrap : Identity a -> a 17 | > unwrap {a} (Id x) = x 18 | 19 | 20 | Identity is a container monad: 21 | 22 | > ||| Membership 23 | > Elem : {A : Type} -> A -> Identity A -> Type 24 | > Elem a1 (Id a2) = a1 = a2 25 | 26 | > ||| Non emptiness 27 | > NonEmpty : {A : Type} -> Identity A -> Type 28 | > NonEmpty _ = Unit 29 | 30 | > ||| 31 | > All : {A : Type} -> (P : A -> Type) -> Identity A -> Type 32 | > All P = P . unwrap 33 | 34 | > ||| Tagging 35 | > tagElem : {A : Type} -> (ia : Identity A) -> Identity (Sigma A (\ a => a `Elem` ia)) 36 | > tagElem (Id a) = Id (MkSigma a Refl) 37 | 38 | 39 | > ||| 40 | > unwrapElemLemma : (ia : Identity a) -> Elem (unwrap ia) ia 41 | > unwrapElemLemma (Id a) = Refl 42 | -------------------------------------------------------------------------------- /frameworks/14-/IsomorphismOperations.lidr: -------------------------------------------------------------------------------- 1 | > module IsomorphismOperations 2 | 3 | > import Data.Fin 4 | > import Control.Isomorphism 5 | 6 | 7 | > %default total 8 | 9 | > %access public export 10 | 11 | 12 | > to : {A, B : Type} -> Iso A B -> (A -> B) 13 | > to (MkIso to from toFrom fromTo) = to 14 | 15 | 16 | > from : {A, B : Type} -> Iso A B -> (B -> A) 17 | > from (MkIso to from toFrom fromTo) = from 18 | 19 | 20 | > toFrom : {A, B : Type} -> (iso : Iso A B) -> (b : B) -> to iso (from iso b) = b 21 | > toFrom (MkIso to from toFrom fromTo) = toFrom 22 | 23 | 24 | > fromTo : {A, B : Type} -> (iso : Iso A B) -> (a : A) -> from iso (to iso a) = a 25 | > fromTo (MkIso to from toFrom fromTo) = fromTo 26 | -------------------------------------------------------------------------------- /frameworks/14-/IsomorphismProperties.lidr: -------------------------------------------------------------------------------- 1 | > module IsomorphismProperties 2 | 3 | > import Control.Isomorphism 4 | 5 | > import IsomorphismOperations 6 | > import FunProperties 7 | > import Basics 8 | 9 | > %default total 10 | > %access public export 11 | 12 | 13 | > ||| 14 | > isoEq : {A, B : Type} -> A = B -> Iso A B 15 | > isoEq Refl = isoRefl 16 | > %freeze isoEq 17 | 18 | 19 | > ||| 20 | > isoCong : {A : Type} -> {x : A} -> {y : A} -> {P : A -> Type} -> x = y -> Iso (P x) (P y) 21 | > isoCong {x} {P} prf = replace {P = \ z => Iso (P x) (P z)} prf isoRefl 22 | > %freeze isoCong 23 | 24 | 25 | Injectivity of to and from 26 | 27 | > injectiveFrom : {A, B : Type} -> (iso : Iso A B) -> Injective1 (from iso) 28 | > injectiveFrom {A} {B} (MkIso to from toFrom fromTo) b1 b2 p = s3 where 29 | > s1 : from b1 = from b2 30 | > s1 = p 31 | > s2 : to (from b1) = to (from b2) 32 | > s2 = cong s1 33 | > s3 : b1 = b2 34 | > s3 = replace2 {a = B} {a1 = to (from b1)} {a2 = b1} 35 | > {b = B} {b1 = to (from b2)} {b2 = b2} 36 | > {P = \ a => \b => a = b} 37 | > (toFrom b1) (toFrom b2) s2 38 | > %freeze injectiveFrom 39 | 40 | 41 | > {- 42 | 43 | > ---} 44 | -------------------------------------------------------------------------------- /frameworks/14-/Issue3405.lidr: -------------------------------------------------------------------------------- 1 | > module Issue3405 2 | 3 | > import SimpleProb 4 | > import NonNegRational 5 | > import NonNegRationalBasicOperations 6 | > import NonNegRationalBasicProperties 7 | > import NatPositive 8 | > import Fraction 9 | > import NumRefinements 10 | > import FractionNormal 11 | > import ListOperations 12 | > import ListProperties 13 | 14 | > %default total 15 | > %access public export 16 | > %auto_implicits off 17 | 18 | > -- %logging 5 19 | 20 | > normalize : {A : Type} -> SimpleProb A -> SimpleProb A 21 | > normalize {A} (MkSimpleProb Nil sum) = MkSimpleProb Nil sum 22 | > normalize {A} (MkSimpleProb (ap :: Nil) sum) = MkSimpleProb (ap :: Nil) sum 23 | > normalize {A} (MkSimpleProb (ap :: ap' :: aps) sum) = MkSimpleProb aps' sum' where 24 | > aps' : List (A, NonNegRational) 25 | > aps' = discardBySndZero (ap :: ap' :: aps) 26 | > sum' : sumMapSnd aps' = 1 27 | > sum' = trans (discardBySndZeroLemma (ap :: ap' :: aps)) sum 28 | 29 | 30 | -------------------------------------------------------------------------------- /frameworks/14-/ListOperationsTest.lidr: -------------------------------------------------------------------------------- 1 | > module ListOperationsTest 2 | 3 | > import Data.List 4 | 5 | > import ListOperations 6 | > import Sigma 7 | 8 | > %default total 9 | > %access public export 10 | > %auto_implicits off 11 | 12 | 13 | > xs : List Nat 14 | > xs = [0,3,2] 15 | 16 | > txs : List (Sigma Nat (\ n => n `Elem` xs)) 17 | > txs = tagElem xs 18 | -------------------------------------------------------------------------------- /frameworks/14-/Matrix.lidr: -------------------------------------------------------------------------------- 1 | > module Matrix 2 | 3 | > import Data.Vect 4 | 5 | > %default total 6 | 7 | > %access public export 8 | 9 | 10 | > Matrix : (m : Nat) -> (n : Nat) -> Type -> Type 11 | > Matrix m n t = Vect m (Vect n t) 12 | -------------------------------------------------------------------------------- /frameworks/14-/MatrixOperations.lidr: -------------------------------------------------------------------------------- 1 | > module MatrixOperations 2 | 3 | > import Data.Fin 4 | > import Data.Vect 5 | 6 | > import Matrix 7 | 8 | > %default total 9 | > %access public export 10 | > %auto_implicits on 11 | 12 | 13 | > row : (Fin m) -> Matrix m n t -> Vect n t 14 | > row k xss = index k xss 15 | 16 | 17 | > toVect : Matrix m n t -> Vect (m * n) t 18 | > toVect = concat 19 | -------------------------------------------------------------------------------- /frameworks/14-/NatBasicProperties.lidr: -------------------------------------------------------------------------------- 1 | > module NatBasicProperties 2 | 3 | > %default total 4 | > %auto_implicits on 5 | > %access export 6 | > -- %access public export 7 | 8 | 9 | > implementation Uninhabited (S n = Z) where 10 | > uninhabited Refl impossible 11 | 12 | 13 | > ||| 14 | > predInjective : (left : Nat) -> (right : Nat) -> Not (S left = S right) -> Not (left = right) 15 | > predInjective left right contra = contra . (eqSucc left right) 16 | > %freeze predInjective 17 | 18 | 19 | > ||| 20 | > succInjective' : (left : Nat) -> (right : Nat) -> Not (left = right) -> Not (S left = S right) 21 | > succInjective' left right contra = contra . (succInjective left right) 22 | > %freeze succInjective' 23 | 24 | 25 | > {- 26 | 27 | > ---} 28 | -------------------------------------------------------------------------------- /frameworks/14-/NatCoprime.lidr: -------------------------------------------------------------------------------- 1 | > module NatCoprime 2 | 3 | 4 | > import NatGCD 5 | > import NatGCDAlgorithm 6 | > import Unique 7 | > import EqualityProperties 8 | > import NatGCDEuclid 9 | > import PairsOperations 10 | > import Sigma 11 | 12 | 13 | > %default total 14 | 15 | > %access public export 16 | 17 | 18 | > ||| 19 | > data Coprime : (m : Nat) -> (n : Nat) -> Type where 20 | > MkCoprime : {m, n : Nat} -> gcdAlg m n = S Z -> Coprime m n 21 | 22 | 23 | > ||| 24 | > CoprimeUnique : {m, n : Nat} -> Unique (Coprime m n) 25 | > CoprimeUnique {m} {n} (MkCoprime p) (MkCoprime q) = cong (uniqueEq (gcdAlg m n) (S Z) p q) 26 | -------------------------------------------------------------------------------- /frameworks/14-/NatDivisor.lidr: -------------------------------------------------------------------------------- 1 | > module NatDivisor 2 | 3 | 4 | > import PairsOperations 5 | 6 | 7 | > %default total 8 | 9 | > %access public export 10 | 11 | 12 | > Divisor : (m : Nat) -> (n : Nat) -> Type 13 | > Divisor m n = Subset Nat (\ q => m * q = n) 14 | 15 | -------------------------------------------------------------------------------- /frameworks/14-/NatDivisorOperations.lidr: -------------------------------------------------------------------------------- 1 | > module NatDivisorOperations 2 | 3 | 4 | > import NatDivisor 5 | 6 | 7 | > %default total 8 | 9 | > %access public export 10 | 11 | 12 | > ||| Exact integer division 13 | > quotient : (m : Nat) -> (d : Nat) -> d `Divisor` m -> Nat 14 | > quotient _ _ (Element q _) = q 15 | 16 | 17 | 18 | 19 | -------------------------------------------------------------------------------- /frameworks/14-/NatGCD.lidr: -------------------------------------------------------------------------------- 1 | > module NatGCD 2 | 3 | 4 | > import NatDivisor 5 | 6 | 7 | > %default total 8 | > %access public export 9 | > %auto_implicits on 10 | 11 | 12 | > ||| 13 | > data GCD : (d : Nat) -> (m : Nat) -> (n : Nat) -> Type where 14 | > MkGCD : d `Divisor` m -> 15 | > d `Divisor` n -> 16 | > ((d' : Nat) -> d' `Divisor` m -> d' `Divisor` n -> d' `Divisor` d) -> 17 | > GCD d m n 18 | 19 | -------------------------------------------------------------------------------- /frameworks/14-/NatGCDAlgorithm.lidr: -------------------------------------------------------------------------------- 1 | > module NatGCDAlgorithm 2 | 3 | 4 | > import NatGCD 5 | > import NatGCDProperties 6 | > import NatGCDEuclid 7 | > import PairsOperations 8 | > import Sigma 9 | 10 | 11 | > %default total 12 | 13 | > %access public export 14 | 15 | > %hide gcd 16 | 17 | 18 | > ||| The GCD algorithm 19 | > gcdAlg : Nat -> Nat -> Nat 20 | > gcdAlg m n = getWitness (euclidGCD m n) 21 | 22 | > gcdAlgLemma : (m : Nat) -> (n : Nat) -> GCD (gcdAlg m n) m n 23 | > gcdAlgLemma m n = getProof (euclidGCD m n) 24 | 25 | > gcdAlgCommutative : (m : Nat) -> (n : Nat) -> gcdAlg m n = gcdAlg n m 26 | > gcdAlgCommutative m n = 27 | > let d1 : Nat 28 | > = gcdAlg m n in 29 | > let d2 : Nat 30 | > = gcdAlg n m in 31 | > let v1 : GCD d1 m n 32 | > = gcdAlgLemma m n in 33 | > let v2 : GCD d2 m n 34 | > = gcdCommutative (gcdAlgLemma n m) in 35 | > gcdUnique d1 d2 v1 v2 36 | 37 | -------------------------------------------------------------------------------- /frameworks/14-/NatGCDAlgorithmTest.1.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import NatGCD 4 | > import NatGCDOperations 5 | > import NatGCDProperties 6 | > import NatGCDAlgorithm 7 | > import NatDivisor 8 | > import NatDivisorOperations 9 | > import NatDivisorProperties 10 | > import PNat 11 | > import PNatOperations 12 | > import PNatProperties 13 | > import NatPositive 14 | 15 | > %default total 16 | 17 | 18 | > m : Nat 19 | > m = 42449 20 | > %freeze m 21 | 22 | > x : (Nat, PNat) 23 | > x = (Main.m, fromNat 6776 (LTESucc LTEZero)) 24 | > %freeze x 25 | 26 | > d' : PNat 27 | > d' = snd Main.x 28 | > d : Nat 29 | > d = toNat Main.d' 30 | > g : Nat 31 | > g = gcdAlg Main.m Main.d 32 | > prf : (GCD Main.g Main.m Main.d) 33 | > prf = gcdAlgLemma Main.m Main.d 34 | > gDm : (Main.g `Divisor` Main.m) 35 | > gDm = gcdDivisorFst Main.prf 36 | > gDd : (Main.g `Divisor` Main.d) 37 | > gDd = gcdDivisorSnd Main.prf 38 | > qmg : Nat 39 | > qmg = quotient Main.m Main.g Main.gDm 40 | > qdg : Nat 41 | > qdg = quotient Main.d Main.g Main.gDd 42 | > zLTd : (Z `LT` Main.d) 43 | > zLTd = toNatLTLemma Main.d' 44 | > zLTqdg : (Z `LT` Main.qdg) 45 | > zLTqdg = quotientPreservesPositivity Main.d Main.g Main.gDd Main.zLTd 46 | > y : (Nat, PNat) 47 | > y = (Main.qmg, fromNat Main.qdg Main.zLTqdg) 48 | 49 | > main : IO () 50 | > main = do putStrLn (show y) 51 | 52 | -------------------------------------------------------------------------------- /frameworks/14-/NatGCDAlgorithmTest.2.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import NatGCD 4 | > import NatGCDOperations 5 | > import NatGCDProperties 6 | > import NatGCDAlgorithm 7 | > import NatDivisor 8 | > import NatDivisorOperations 9 | > import NatDivisorProperties 10 | > import PNat 11 | > import PNatOperations 12 | > import PNatProperties 13 | > import NatPositive 14 | 15 | > %default total 16 | 17 | 18 | > m : Nat 19 | > m = 2067 20 | > %freeze m 21 | 22 | > x : (Nat, PNat) 23 | > x = (Main.m, fromNat 616 (LTESucc LTEZero)) 24 | 25 | > y : (Nat, PNat) 26 | > y = let m : Nat 27 | > = fst Main.x in 28 | > let d' : PNat 29 | > = snd Main.x in 30 | > let d : Nat 31 | > = toNat d' in 32 | > let g : Nat 33 | > = gcdAlg m d in 34 | > let prf : (GCD g m d) 35 | > = gcdAlgLemma m d in 36 | > let gDm : (g `Divisor` m) 37 | > = gcdDivisorFst prf in 38 | > let gDd : (g `Divisor` d) 39 | > = gcdDivisorSnd prf in 40 | > let qmg : Nat 41 | > = quotient m g gDm in 42 | > let qdg : Nat 43 | > = quotient d g gDd in 44 | > let zLTd : (Z `LT` d) 45 | > = toNatLTLemma d' in 46 | > let zLTqdg : (Z `LT` qdg) 47 | > = quotientPreservesPositivity d g gDd zLTd in 48 | > (qmg, fromNat qdg zLTqdg) 49 | 50 | > main : IO () 51 | > main = do putStrLn (show y) 52 | 53 | -------------------------------------------------------------------------------- /frameworks/14-/NatGCDEuclidStrippedDown.lidr: -------------------------------------------------------------------------------- 1 | > module NatGCDEuclidStrippedDown 2 | 3 | 4 | > import NatOperations 5 | > import NatLTEProperties 6 | 7 | 8 | > %default total 9 | 10 | > %access public export 11 | 12 | 13 | Euclid's greatest common divisor algorithm 14 | 15 | 16 | > --{- 17 | > %assert_total 18 | > euclidGCD : (m : Nat) -> (n : Nat) -> Nat 19 | > euclidGCD m Z = m 20 | > euclidGCD Z n = n 21 | > euclidGCD (S m) (S n) with (decLTE (S m) (S n)) 22 | > | (Yes p) = euclidGCD (S m) (S n - S m) 23 | > | (No p) = euclidGCD (S m - S n) (S n) 24 | > ---} 25 | 26 | 27 | > {- 28 | > %assert_total 29 | > euclidGCD : (m : Nat) -> (n : Nat) -> Nat 30 | > euclidGCD m Z = m 31 | > euclidGCD Z n = n 32 | > euclidGCD (S m) (S n) with (decEq m n) 33 | > | (Yes _) = S m 34 | > | (No _) with (decEq (m - n) Z) 35 | > | (Yes _) = euclidGCD (S m) (S n - S m) 36 | > | (No _) = euclidGCD (S m - S n) (S n) 37 | > ---} 38 | 39 | 40 | > {- 41 | > %assert_total 42 | > euclidGCD : (m : Nat) -> (n : Nat) -> Nat 43 | > euclidGCD m Z = m 44 | > euclidGCD Z n = n 45 | > euclidGCD (S m) (S n) = if (S m <= S n) 46 | > then euclidGCD (S m) (S n - S m) 47 | > else euclidGCD (S m - S n) (S n) 48 | > ---} 49 | -------------------------------------------------------------------------------- /frameworks/14-/NatGCDEuclidStrippedDownTest.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import NatGCDEuclidStrippedDown 4 | 5 | > %default total 6 | 7 | 8 | > m : Nat 9 | > n : Nat 10 | 11 | > d : Nat 12 | > d = euclidGCD m n 13 | 14 | > m = 42449 15 | > n = 6776 16 | 17 | > main : IO () 18 | > main = do putStrLn (show d) 19 | 20 | -------------------------------------------------------------------------------- /frameworks/14-/NatGCDEuclidTest.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import NatGCD 4 | > import NatGCDOperations 5 | > import NatGCDProperties 6 | > import NatGCDEuclid 7 | > import NatDivisor 8 | > import NatDivisorOperations 9 | > import Sigma 10 | > import PairsOperations 11 | 12 | 13 | > %default total 14 | 15 | 16 | > m : Nat 17 | > n : Nat 18 | 19 | > d : Nat 20 | > d = getWitness (euclidGCD m n) 21 | 22 | > prf : GCD Main.d Main.m Main.n 23 | > prf = getProof (euclidGCD m n) 24 | 25 | > dDm : Main.d `Divisor` Main.m 26 | > dDm = gcdDivisorFst prf 27 | 28 | > dDn : Main.d `Divisor` Main.n 29 | > dDn = gcdDivisorSnd prf 30 | 31 | > m' : Nat 32 | > m' = quotient Main.m Main.d Main.dDm 33 | 34 | > n' : Nat 35 | > n' = quotient Main.n Main.d Main.dDn 36 | 37 | > m = 42449 38 | > n = 6776 39 | 40 | > main : IO () 41 | > main = do putStrLn (show d) 42 | > putStrLn (show m') 43 | 44 | -------------------------------------------------------------------------------- /frameworks/14-/NatGCDOperations.lidr: -------------------------------------------------------------------------------- 1 | > module NatGCDOperations 2 | 3 | 4 | > import NatGCD 5 | > import NatDivisor 6 | 7 | 8 | > %default total 9 | > %access public export 10 | > %auto_implicits on 11 | 12 | 13 | > ||| 14 | > gcdDivisorFst : GCD d m n -> d `Divisor` m 15 | > gcdDivisorFst {d} (MkGCD dDm dDn dG) = dDm 16 | 17 | > ||| 18 | > gcdDivisorSnd : GCD d m n -> d `Divisor` n 19 | > gcdDivisorSnd {d} (MkGCD dDm dDn dG) = dDn 20 | 21 | > ||| 22 | > gcdDivisorGreatest : GCD d m n -> ((d' : Nat) -> d' `Divisor` m -> d' `Divisor` n -> d' `Divisor` d) 23 | > gcdDivisorGreatest {d} (MkGCD dDm dDn dG) = dG 24 | 25 | 26 | -------------------------------------------------------------------------------- /frameworks/14-/NatOperations.lidr: -------------------------------------------------------------------------------- 1 | > module NatOperations 2 | 3 | > import NatPredicates 4 | 5 | > %default total 6 | > %access public export 7 | > %hide (-) 8 | 9 | 10 | Predecessor: 11 | 12 | > pred : (n : Nat) -> Z `LT` n -> Nat 13 | > pred Z prf = absurd prf 14 | > pred (S m) _ = m 15 | 16 | 17 | Infix minus: 18 | 19 | > (-) : Nat -> Nat -> Nat 20 | > (-) = minus 21 | 22 | 23 | Division: 24 | 25 | > -- quotient : (m : Nat) -> (d : Nat) -> d `Divisor` m -> Nat 26 | > -- quotient _ _ (Evidence q _) = q 27 | 28 | 29 | 30 | 31 | -------------------------------------------------------------------------------- /frameworks/14-/NatPredicates.lidr: -------------------------------------------------------------------------------- 1 | > module NatPredicates 2 | 3 | > import Sigma 4 | 5 | > %default total 6 | > %access public export 7 | > %auto_implicits on 8 | 9 | 10 | Divisor (following an idea from Tim Richter): 11 | 12 | > {- 13 | > data Divisor : (m : Nat) -> (n : Nat) -> Type where 14 | > mkDivisor : (m : Nat) -> (n : Nat) -> Exists (\ q => m * q = n) -> Divisor m n 15 | > -} 16 | 17 | > Divisor : (m : Nat) -> (n : Nat) -> Type 18 | > Divisor m n = Exists (\ q => m * q = n) 19 | 20 | 21 | Greatest common divisor (following an idea from Tim Richter): 22 | 23 | > data GCD : (d : Nat) -> (m : Nat) -> (n : Nat) -> Type where 24 | > MkGCD : d `Divisor` m -> 25 | > d `Divisor` n -> 26 | > ((d' : Nat) -> d' `Divisor` m -> d' `Divisor` n -> d' `Divisor` d) -> 27 | > GCD d m n 28 | 29 | > gcd : Sigma Nat (\ d => GCD d m n) -> Nat 30 | > gcd (MkSigma d _) = d 31 | 32 | > gcdDivisorFst : GCD d m n -> d `Divisor` m 33 | > gcdDivisorFst {d} (MkGCD dDm dDn dG) = dDm 34 | 35 | > gcdDivisorSnd : GCD d m n -> d `Divisor` n 36 | > gcdDivisorSnd {d} (MkGCD dDm dDn dG) = dDn 37 | 38 | > gcdDivisorGreatest : GCD d m n -> ((d' : Nat) -> d' `Divisor` m -> d' `Divisor` n -> d' `Divisor` d) 39 | > gcdDivisorGreatest {d} (MkGCD dDm dDn dG) = dG 40 | 41 | 42 | Coprime (following an idea from Tim Richter): 43 | 44 | > data Coprime : (m : Nat) -> (n : Nat) -> Type where 45 | > MkCoprime : GCD d m n -> d = S Z -> Coprime m n 46 | -------------------------------------------------------------------------------- /frameworks/14-/NatProperties.TODO: -------------------------------------------------------------------------------- 1 | * 2015.11.20 2 | ** For consistency and as a preparation for making certain arguments 3 | implicit, rearrange argument lists in order to avoid value - property 4 | - value - property sequences. For instance, rewrite 5 | 6 | lala : (m, n : Nat) -> LT m n -> (o, p : Nat) -> LT o p -> Lala 7 | 8 | as 9 | 10 | lala : (m, n, o, p : Nat) -> LT m n -> LT o p -> Lala -------------------------------------------------------------------------------- /frameworks/14-/NonNegRational.lidr: -------------------------------------------------------------------------------- 1 | > module NonNegRational 2 | 3 | 4 | > import Fraction 5 | > import FractionNormal 6 | 7 | 8 | > %default total 9 | 10 | > %access public export 11 | 12 | 13 | > ||| Non negative rational numbers 14 | > NonNegRational : Type 15 | > NonNegRational = Subset Fraction Normal 16 | 17 | -------------------------------------------------------------------------------- /frameworks/14-/NonNegRational3001.lidr: -------------------------------------------------------------------------------- 1 | > import NonNegRational2 2 | > import Fraction 3 | > import NatProperties 4 | > %default total 5 | 6 | > zLTs : {m : Nat} -> LT Z (S m) 7 | > zLTs {m} = ltZS m 8 | 9 | > x' : Fraction 10 | > x' = (7, fromNat 3 zLTs) 11 | -------------------------------------------------------------------------------- /frameworks/14-/NonNegRationalBasicOperations.lidr: -------------------------------------------------------------------------------- 1 | > module NonNegRationalBasicOperations 2 | 3 | 4 | > import NonNegRational 5 | > import Fraction 6 | > import FractionBasicOperations 7 | > import FractionBasicProperties 8 | > import FractionNormalize 9 | > import FractionNormalizeProperties 10 | > import PairsOperations 11 | > import Sigma 12 | 13 | > %default total 14 | > %access public export 15 | 16 | 17 | > ||| 18 | > toFraction : NonNegRational -> Fraction 19 | > toFraction = PairsOperations.Subset.getWitness 20 | > -- %freeze toFraction 21 | 22 | 23 | > ||| 24 | > fromFraction : Fraction -> NonNegRational 25 | > fromFraction x = Element (normalize x) (normalNormalize x) 26 | > %freeze fromFraction 27 | 28 | 29 | > ||| The numerator of a non-negative rational 30 | > num : NonNegRational -> Nat 31 | > num = num . toFraction 32 | > -- %freeze num 33 | 34 | 35 | > ||| The denominator of a non-negative rational 36 | > den : NonNegRational -> Nat 37 | > den = den . toFraction 38 | > -- %freeze den 39 | 40 | 41 | > ||| Every natural number is a non-negative rational 42 | > fromNat : (n : Nat) -> NonNegRational 43 | > fromNat = fromFraction . fromNat 44 | > -- %freeze fromNat 45 | 46 | 47 | > ||| Addition of non-negative rational numbers 48 | > plus : NonNegRational -> NonNegRational -> NonNegRational 49 | > plus x y = fromFraction (toFraction x + toFraction y) 50 | > -- %freeze plus 51 | 52 | 53 | > ||| Multiplication of non-negative rational numbers 54 | > mult : NonNegRational -> NonNegRational -> NonNegRational 55 | > mult x y = fromFraction (toFraction x * toFraction y) 56 | > -- %freeze mult 57 | 58 | 59 | -------------------------------------------------------------------------------- /frameworks/14-/NonNegRationalBasicTests.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import NonNegRational 4 | > import NonNegRationalBasicOperations 5 | > import NonNegRationalBasicProperties 6 | > import Fraction 7 | > import FractionPredicates 8 | > import FractionBasicOperations 9 | > import PNat 10 | > import PNatOperations 11 | > import PNatProperties 12 | > import NatPositive 13 | 14 | 15 | > %default total 16 | > %auto_implicits off 17 | 18 | 19 | > f1 : Fraction 20 | > f1 = (0, Element (S Z) MkPositive) 21 | 22 | > f2 : Fraction 23 | > f2 = (0, Element (S 6) MkPositive) 24 | 25 | > z1 : NonNegRational 26 | > z1 = fromFraction f1 27 | 28 | > z2 : NonNegRational 29 | > z2 = fromFraction f2 30 | 31 | > z1EQz2 : z1 = z2 32 | > z1EQz2 = fromFractionEqLemma f1 f2 Refl 33 | 34 | > {- 35 | 36 | > x : NonNegRational 37 | > x = fromFraction (2067, PNat.fromNat 616 (LTESucc LTEZero)) 38 | 39 | > y : NonNegRational 40 | > y = fromFraction (32, PNat.fromNat 11 (LTESucc LTEZero)) 41 | 42 | > z : NonNegRational 43 | > z = x + y 44 | 45 | > main : IO () 46 | > main = do putStrLn (show z1) 47 | > putStrLn (show z2) 48 | > putStrLn (show x) 49 | > putStrLn (show y) 50 | > putStrLn (show z) 51 | 52 | > -} 53 | -------------------------------------------------------------------------------- /frameworks/14-/NonNegRationalMeasures.lidr: -------------------------------------------------------------------------------- 1 | > module NonNegRationalMeasures 2 | 3 | > import Syntax.PreorderReasoning 4 | 5 | > import NonNegRational 6 | > import NonNegRationalBasicOperations 7 | > import NonNegRationalBasicProperties 8 | > import NatPositive 9 | > import Fraction 10 | > import FractionNormal 11 | 12 | > %default total 13 | > %access public export 14 | > %auto_implicits off 15 | 16 | 17 | > ||| 18 | > factor : {A : Type} -> List A -> NonNegRational 19 | > factor Nil = 1 20 | > factor (a :: as) = fromFraction (1, Element (S (length as)) MkPositive) 21 | 22 | 23 | > ||| 24 | > average : List NonNegRational -> NonNegRational 25 | > average xs = (sum xs) * (factor xs) 26 | 27 | 28 | > {- 29 | 30 | > ---} 31 | 32 | -------------------------------------------------------------------------------- /frameworks/14-/NonNegRationalPredicates.lidr: -------------------------------------------------------------------------------- 1 | > module NonNegRationalPredicates 2 | 3 | > import NonNegRational 4 | > import NonNegRationalBasicOperations 5 | > import Fraction 6 | > import FractionPredicates 7 | 8 | > %default total 9 | > %access public export 10 | > %auto_implicits off 11 | 12 | 13 | > ||| Proofs that `x` is less than or equal to `y` 14 | > ||| @ x the smaller number 15 | > ||| @ y the larger number 16 | > LTE : (x, y : NonNegRational) -> Type 17 | > LTE x y = FractionPredicates.LTE (toFraction x) (toFraction y) 18 | 19 | 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /frameworks/14-/NonNegRationalTest2.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import NonNegRational2 4 | > import PNatOperations 5 | 6 | > %default total 7 | 8 | 9 | > x : NonNegRational 10 | > x = fromFraction (25, PNat.fromNat 56 (LTESucc LTEZero)) 11 | > y : NonNegRational 12 | > y = fromFraction (32, PNat.fromNat 11 (LTESucc LTEZero)) 13 | > z : NonNegRational 14 | > z = x + y 15 | 16 | > main : IO () 17 | > main = putStrLn $ show z 18 | 19 | -------------------------------------------------------------------------------- /frameworks/14-/NumOperations.lidr: -------------------------------------------------------------------------------- 1 | > module Num 2 | 3 | > import Data.Vect 4 | 5 | > import Matrix 6 | 7 | > %default total 8 | > %access public export 9 | > %auto_implicits on 10 | 11 | 12 | > ||| Scalar-vector "multiplication" 13 | > multSV : (Num t) => t -> Vect m t -> Vect m t 14 | > -- multSV _ Nil = Nil 15 | > -- multSV x (y :: ys) = (x * y) :: (multSV x ys) 16 | > multSV x = map (x *) 17 | 18 | 19 | > ||| Vector-matrix "multiplication" (kind of) 20 | > multVM : (Num t) => Vect m t -> Matrix m n t -> Matrix m n t 21 | > -- multVM {m = Z} {n} Nil Nil = Nil 22 | > -- multVM {m = S l} {n} (x :: xs) (v :: vs) = (multSV x v) :: (multVM xs vs) 23 | > multVM {m} {n} xs xss = map (uncurry multSV) (zip xs xss) 24 | 25 | 26 | > ||| 27 | > multConcat : (Num t) => Vect m t -> Vect m (Vect n t) -> Vect (m * n) t 28 | > multConcat {m = Z} {n} Nil Nil = Nil 29 | > multConcat {m = S l} {n} (x :: xs) (v :: vs) = (multSV x v) ++ multConcat xs vs 30 | -------------------------------------------------------------------------------- /frameworks/14-/NumRefinements.lidr: -------------------------------------------------------------------------------- 1 | > module NumRefinements 2 | 3 | 4 | > %default total 5 | 6 | > %access public export 7 | 8 | 9 | > ||| 10 | > interface (Num t) => NumPlusZeroNeutral t where 11 | > plusZeroLeftNeutral : (x : t) -> 0 + x = x 12 | > plusZeroRightNeutral : (x : t) -> x + 0 = x 13 | 14 | 15 | > ||| 16 | > interface (NumPlusZeroNeutral t) => NumPlusAssociative t where 17 | > -- interface (Num t) => NumPlusAssociative t where 18 | > plusAssociative : (x, y, z : t) -> x + (y + z) = (x + y) + z 19 | 20 | 21 | > ||| 22 | > interface (NumPlusAssociative t) => NumMultZeroOne t where 23 | > -- interface (Num t) => NumMultZeroOne t where 24 | > multZeroRightZero : (x : t) -> x * 0 = 0 25 | > multZeroLeftZero : (x : t) -> 0 * x = 0 26 | > multOneRightNeutral : (x : t) -> x * 1 = x 27 | > multOneLeftNeutral : (x : t) -> 1 * x = x 28 | 29 | 30 | > ||| 31 | > interface (NumMultZeroOne t) => NumMultDistributesOverPlus t where 32 | > -- interface (Num t) => NumMultDistributesOverPlus t where 33 | > multDistributesOverPlusRight : (x, y, z : t) -> x * (y + z) = (x * y) + (x * z) 34 | > multDistributesOverPlusLeft : (x, y, z : t) -> (x + y) * z = (x * z) + (y * z) 35 | -------------------------------------------------------------------------------- /frameworks/14-/PNat.lidr: -------------------------------------------------------------------------------- 1 | > module PNat 2 | 3 | 4 | > import Syntax.PreorderReasoning 5 | 6 | > import NatPositive 7 | 8 | 9 | > %default total 10 | > %access public export 11 | 12 | 13 | > ||| Positive natural numbers as sigma types 14 | > PNat : Type 15 | > PNat = Subset Nat Positive 16 | -------------------------------------------------------------------------------- /frameworks/14-/PNatOperations.lidr: -------------------------------------------------------------------------------- 1 | > module PNatOperations 2 | 3 | > import PNat 4 | > import NatPositive 5 | > import NatOperations 6 | > import NatOperationsProperties 7 | > import PairsOperations 8 | 9 | > %default total 10 | > %access public export 11 | 12 | 13 | > ||| The predecessor of a PNat 14 | > pred : PNat -> Nat 15 | > pred (Element _ (MkPositive {n})) = n 16 | 17 | 18 | > ||| 19 | > fromNat : (m : Nat) -> Z `LT` m -> PNat 20 | > {- 21 | > fromNat Z zLTz = absurd zLTz 22 | > fromNat (S m) _ = Element (S m) (MkPositive {n = m}) 23 | > ----} 24 | > --{- 25 | > fromNat m prf = Element m pm where 26 | > pm : Positive m 27 | > pm = fromSucc (pred m prf) m (predLemma m prf) 28 | > ---} 29 | 30 | 31 | > ||| 32 | > toNat : PNat -> Nat 33 | > toNat = getWitness 34 | 35 | 36 | > ||| 37 | > plus : PNat -> PNat -> PNat 38 | > plus (Element m pm) (Element n pn) = Element (m + n) (plusPreservesPositivity pm pn) 39 | 40 | 41 | > ||| 42 | > (+) : PNat -> PNat -> PNat 43 | > (+) = plus 44 | 45 | 46 | > ||| 47 | > mult : PNat -> PNat -> PNat 48 | > mult (Element m pm) (Element n pn) = Element (m * n) (multPreservesPositivity pm pn) 49 | 50 | 51 | > ||| 52 | > (*) : PNat -> PNat -> PNat 53 | > (*) = mult 54 | 55 | 56 | > {- 57 | 58 | > ---} 59 | -------------------------------------------------------------------------------- /frameworks/14-/PairProperties.lidr: -------------------------------------------------------------------------------- 1 | > module PairProperties 2 | 3 | > %default total 4 | > %access public export 5 | > %auto_implicits off 6 | 7 | 8 | > pairLemma : {A, B : Type} -> (ab : (A, B)) -> ab = (fst ab, snd ab) 9 | > pairLemma (a, b) = Refl 10 | -------------------------------------------------------------------------------- /frameworks/14-/PairsOperations.lidr: -------------------------------------------------------------------------------- 1 | > module PairsOperations 2 | 3 | 4 | > import Sigma 5 | 6 | 7 | > %default total 8 | 9 | > %access public export 10 | > %hide getWitness 11 | > %hide getProof 12 | 13 | 14 | > namespace Exists 15 | > getWitness : {P : a -> Type} -> Exists {a} P -> a 16 | > getWitness (Evidence x pf) = x 17 | > getProof : {P : a -> Type} -> (x : Exists {a} P) -> P (getWitness x) 18 | > getProof (Evidence x pf) = pf 19 | 20 | 21 | > namespace Subset 22 | > getWitness : {P : a -> Type} -> Subset a P -> a 23 | > getWitness (Element x pf) = x 24 | > getProof : {P : a -> Type} -> (x : Subset a P) -> P (getWitness x) 25 | > getProof (Element x pf) = pf 26 | 27 | 28 | > namespace Sigma 29 | > getWitness : {P : a -> Type} -> Sigma a P -> a 30 | > getWitness (MkSigma x pf) = x 31 | > getProof : {P : a -> Type} -> (x : Sigma a P) -> P (getWitness x) 32 | > getProof (MkSigma x pf) = pf 33 | 34 | 35 | > {- 36 | 37 | > ---} 38 | 39 | -------------------------------------------------------------------------------- /frameworks/14-/Preorder.lidr: -------------------------------------------------------------------------------- 1 | > module Preorder 2 | 3 | 4 | > %default total 5 | > %access public export 6 | 7 | 8 | > ||| Preorder 9 | > data Preorder : Type -> Type where 10 | > MkPreorder : {A : Type} -> 11 | > (R : A -> A -> Type) -> 12 | > (reflexive : (x : A) -> R x x) -> 13 | > (transitive : (x : A) -> (y : A) -> (z : A) -> R x y -> R y z -> R x z) -> 14 | > Preorder A 15 | 16 | 17 | > {- 18 | 19 | > ||| Preorder on t 20 | > class Preorder t where 21 | > total C : t -> t -> Type 22 | > total reflexive : (x : t) -> C x x 23 | > total transitive : (x : t) -> (y : t) -> (z : t) -> C x y -> C y z -> C x z 24 | 25 | 26 | > ||| Total preorder on t 27 | > class (Preorder t) => TotalPreorder t where 28 | > total totalPre : (x : t) -> (y : t) -> Either (C x y) (C y x) 29 | 30 | > -} 31 | 32 | 33 | > {- 34 | 35 | > ||| Preorder on t 36 | > class Preorder (t : Type) (po : t -> t -> Type) where 37 | > total reflexive : (x : t) -> po x x 38 | > total transitive : (x : t) -> (y : t) -> (z : t) -> po x y -> po y z -> po x z 39 | 40 | > ||| Preorders on |t1| induce preorders on |(t1, t2)| 41 | > instance Preorder t1 po => Preorder (t1, t2) (\ x => \ y => po (fst x) (fst y)) where 42 | > reflexive x = reflexive (fst x) 43 | > transitive x y z xy yz = transitive (fst x) (fst y) (fst z) xy yz 44 | 45 | > -} 46 | 47 | 48 | > {- 49 | 50 | > class (Preorder t to) => Preordered t (to : t -> t -> Type) | t where 51 | > total preorder : (a : t) -> (b : t) -> Either (to a b) (to b a) 52 | 53 | > -} 54 | -------------------------------------------------------------------------------- /frameworks/14-/Prop.lidr: -------------------------------------------------------------------------------- 1 | > module Prop 2 | 3 | > %default total 4 | 5 | > %access public export 6 | 7 | 8 | > Prop : Type 9 | > Prop = Type 10 | -------------------------------------------------------------------------------- /frameworks/14-/Sigma.lidr: -------------------------------------------------------------------------------- 1 | > module Sigma 2 | 3 | > %default total 4 | 5 | > %access public export 6 | 7 | > %hide Sigma 8 | > %hide MkSigma 9 | 10 | 11 | > data Sigma : (a : Type) -> (P : a -> Type) -> Type where 12 | > MkSigma : .{P : a -> Type} -> (x : a) -> (pf : P x) -> Sigma a P 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | -------------------------------------------------------------------------------- /frameworks/14-/SigmaOperations.lidr: -------------------------------------------------------------------------------- 1 | > module SigmaOperations 2 | 3 | > import Data.Fin 4 | > import Data.Vect 5 | > import Control.Isomorphism 6 | 7 | > import Sigma 8 | > import Finite 9 | > import Decidable 10 | > import FiniteOperations 11 | > import VectOperations 12 | 13 | 14 | > %default total 15 | 16 | > %access public export 17 | 18 | 19 | > ||| 20 | > outl : {A : Type} -> {P : A -> Type} -> Sigma A P -> A 21 | > outl (MkSigma a _) = a 22 | 23 | 24 | > ||| 25 | > outr : {A : Type} -> {P : A -> Type} -> (s : Sigma A P) -> P (outl s) 26 | > outr (MkSigma _ p) = p 27 | 28 | 29 | > ||| Maps a finite type |A| and a decidable predicate |P| to a vector |Sigma A P| values 30 | > toVectSigma : {A : Type} -> 31 | > {P : A -> Type} -> 32 | > Finite A -> 33 | > Dec1 P -> 34 | > Sigma Nat (\ n => Vect n (Sigma A P)) 35 | > toVectSigma fA d1P = filterTagSigma d1P (toVect fA) 36 | -------------------------------------------------------------------------------- /frameworks/14-/SignProperties.lidr: -------------------------------------------------------------------------------- 1 | > module SignProperties 2 | 3 | > import Data.Sign 4 | 5 | > %default total 6 | 7 | 8 | > instance Eq Sign where 9 | > (==) Plus Plus = True 10 | > (==) Plus Zero = False 11 | > (==) Plus Minus = False 12 | > (==) Zero Plus = False 13 | > (==) Zero Zero = True 14 | > (==) Zero Minus = False 15 | > (==) Minus Minus = True 16 | > (==) Minus Zero = False 17 | > (==) Minus Plus = False 18 | 19 | > ||| 20 | > plusNotZero : Plus = Zero -> Void 21 | > plusNotZero Refl impossible 22 | > %freeze plusNotZero 23 | 24 | > ||| 25 | > plusNotMinus : Plus = Minus -> Void 26 | > plusNotMinus Refl impossible 27 | > %freeze plusNotMinus 28 | 29 | > ||| 30 | > zeroNotMinus : Zero = Minus -> Void 31 | > zeroNotMinus Refl impossible 32 | > %freeze zeroNotMinus 33 | 34 | 35 | > instance DecEq Sign where 36 | > decEq Plus Plus = Yes Refl 37 | > decEq Plus Zero = No plusNotZero 38 | > decEq Plus Minus = No plusNotMinus 39 | > decEq Zero Plus = No (negEqSym plusNotZero) 40 | > decEq Zero Zero = Yes Refl 41 | > decEq Zero Minus = No zeroNotMinus 42 | > decEq Minus Plus = No (negEqSym plusNotMinus) 43 | > decEq Minus Zero = No (negEqSym zeroNotMinus) 44 | > decEq Minus Minus = Yes Refl 45 | -------------------------------------------------------------------------------- /frameworks/14-/SimpleProb.lidr: -------------------------------------------------------------------------------- 1 | > module SimpleProb 2 | 3 | > import NonNegRational 4 | > import NonNegRationalBasicProperties 5 | > import NumRefinements 6 | > import ListOperations 7 | 8 | > %default total 9 | > %access public export 10 | > %auto_implicits off 11 | 12 | 13 | > ||| 14 | > data SimpleProb : Type -> Type where 15 | > MkSimpleProb : {A : Type} -> 16 | > (aps : List (A, NonNegRational)) -> 17 | > sumMapSnd aps = 1 -> 18 | > SimpleProb A 19 | 20 | 21 | > {- 22 | 23 | > ---} 24 | -------------------------------------------------------------------------------- /frameworks/14-/SimpleProbBasicProperties.lidr: -------------------------------------------------------------------------------- 1 | > module SimpleProbBasicProperties 2 | 3 | > import Data.List 4 | > import Syntax.PreorderReasoning 5 | 6 | > import SimpleProb 7 | > import SimpleProbBasicOperations 8 | > import NonNegRational 9 | > import NonNegRationalBasicOperations 10 | > import NonNegRationalBasicProperties 11 | > import NumRefinements 12 | > import ListOperations 13 | > import ListProperties 14 | > import NatPositive 15 | > import FractionNormal 16 | 17 | > %default total 18 | > %access public export 19 | > -- %auto_implicits off 20 | 21 | 22 | > ||| 23 | > toListLemma : {A : Type} -> (sp : SimpleProb A) -> sumMapSnd (toList sp) = 1 24 | > toListLemma (MkSimpleProb _ prf) = prf 25 | 26 | 27 | > ||| 28 | > sumProbsLemma : {A : Type} -> (sp : SimpleProb A) -> sum (probs sp) = 1 29 | > sumProbsLemma {A} sp = ( sum (map snd (toList (normalize sp))) ) 30 | > ={ Refl }= 31 | > ( sumMapSnd (toList (normalize sp)) ) 32 | > ={ toListLemma (normalize sp) }= 33 | > ( 1 ) 34 | > QED 35 | 36 | 37 | > ||| 38 | > lengthSupportProbsLemma : {A : Type} -> (sp : SimpleProb A) -> 39 | > length (support sp) = length (probs sp) 40 | > lengthSupportProbsLemma sp = lengthLemma (toList (normalize sp)) fst snd 41 | 42 | 43 | > ||| SimpleProb is an implementation of Show 44 | > implementation Show a => Show (SimpleProb a) where 45 | > show sp = show (toList sp) 46 | 47 | 48 | > {- 49 | 50 | > ---} 51 | -------------------------------------------------------------------------------- /frameworks/14-/SimpleProbMeasures.lidr: -------------------------------------------------------------------------------- 1 | > module SimpleProbMeasures 2 | 3 | > import SimpleProb 4 | > import SimpleProbBasicOperations 5 | > import NonNegRational 6 | > import NonNegRationalBasicOperations 7 | > import NonNegRationalBasicProperties 8 | > import ListOperations 9 | 10 | > -- postulate monotoneAverage 11 | > import NonNegRationalPredicates 12 | > import SimpleProbMonadicOperations 13 | 14 | > %default total 15 | > %access public export 16 | > %auto_implicits off 17 | 18 | 19 | > ||| 20 | > average : SimpleProb NonNegRational -> NonNegRational 21 | > average = sumProds . toList 22 | 23 | 24 | > ||| |average| is monotone 25 | > postulate monotoneAverage : {A : Type} -> 26 | > (f : A -> NonNegRational) -> (g : A -> NonNegRational) -> 27 | > (p : (a : A) -> f a `LTE` g a) -> 28 | > (as : SimpleProb A) -> 29 | > average (fmap f as) `LTE` average (fmap g as) 30 | -------------------------------------------------------------------------------- /frameworks/14-/SubType.lidr: -------------------------------------------------------------------------------- 1 | > module SubType 2 | 3 | 4 | > import Unique 5 | > import Sigma 6 | 7 | 8 | > %default total 9 | 10 | > %access public export 11 | 12 | 13 | > ||| For a type |A| and a unique predicate |P|, a subtype of |A| is just a set of values of |A| that fulfills |P| 14 | > SubType : (A : Type) -> (P : A -> Type) -> Unique1 P -> Type 15 | > SubType A P _ = Sigma A P 16 | -------------------------------------------------------------------------------- /frameworks/14-/SubsetOperations.lidr: -------------------------------------------------------------------------------- 1 | > module SubsetOperations 2 | 3 | > import Data.Fin 4 | > import Data.Vect 5 | > import Control.Isomorphism 6 | 7 | > import Sigma 8 | > import PairsOperations 9 | > import Finite 10 | > import Decidable 11 | > import FiniteOperations 12 | > import VectOperations 13 | 14 | 15 | > %default total 16 | 17 | > %access public export 18 | 19 | 20 | > ||| 21 | > outl : {A : Type} -> {P : A -> Type} -> Subset A P -> A 22 | > outl = getWitness 23 | 24 | 25 | > ||| 26 | > outr : {A : Type} -> {P : A -> Type} -> (s : Subset A P) -> P (outl s) 27 | > outr = getProof 28 | 29 | 30 | > ||| Maps a finite type |A| and a decidable predicate |P| to a vector |Subset A P| values 31 | > toVectSubset : {A : Type} -> 32 | > {P : A -> Type} -> 33 | > Finite A -> 34 | > Dec1 P -> 35 | > Sigma Nat (\ n => Vect n (Subset A P)) 36 | > toVectSubset fA d1P = filterTagSubset d1P (toVect fA) 37 | -------------------------------------------------------------------------------- /frameworks/14-/TestFractionBasicOperations.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import Fraction 4 | > import FractionBasicOperations 5 | > import FractionBasicProperties 6 | > import PNat 7 | > import PNatOperations 8 | > import PNatProperties 9 | > import NatPositive 10 | 11 | > %default total 12 | > %auto_implicits off 13 | 14 | 15 | > dx : PNat 16 | > dx = Element (S 615) (MkPositive {n = 615}) 17 | > x : Fraction 18 | > x = (2067, dx) 19 | 20 | > dy : PNat 21 | > dy = Element (S 10) (MkPositive {n = 10}) 22 | > y : Fraction 23 | > y = (32, dy) 24 | 25 | > dz : PNat 26 | > dz = Element (S 12748) (MkPositive {n = 12748}) 27 | > z : Fraction 28 | > z = (1, dz) 29 | 30 | > main : IO () 31 | > main = do putStrLn ("x = " ++ show x) 32 | > putStrLn ("y = " ++ show y) 33 | > putStrLn ("z = " ++ show z) 34 | > putStrLn ("x + y = " ++ show (x + y)) 35 | > putStrLn ("y + x = " ++ show (y + x)) 36 | > putStrLn ("x * y = " ++ show (x * y)) 37 | > putStrLn ("y * x = " ++ show (y * x)) 38 | > putStrLn ("(x + y) + z = " ++ show ((x + y) + z)) 39 | > putStrLn ("x + (y + z) = " ++ show (x + (y + z))) 40 | > putStrLn ("(x * y) * z = " ++ show ((x * y) * z)) 41 | > putStrLn ("x * (y * z) = " ++ show (x * (y * z))) 42 | 43 | 44 | 45 | -------------------------------------------------------------------------------- /frameworks/14-/TestNatBasic1.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > %default total 4 | > %auto_implicits off 5 | 6 | 7 | > x : Nat 8 | > x = 1 9 | 10 | > y : Nat 11 | > y = 2 12 | 13 | > z : Nat 14 | > z = 2 15 | 16 | > yEQz : y = z 17 | > yEQz = Refl 18 | 19 | > xs : List Nat 20 | > xs = [x, y, z] 21 | 22 | > sxs : sum xs = 5 23 | > sxs = Refl 24 | 25 | > main : IO () 26 | > main = do putStrLn ("x = " ++ show x) 27 | > putStrLn ("y = " ++ show y) 28 | > putStrLn ("z = " ++ show z) 29 | > putStrLn ("x + y = " ++ show (x + y)) 30 | > putStrLn ("y + x = " ++ show (y + x)) 31 | > putStrLn ("x * y = " ++ show (x * y)) 32 | > putStrLn ("y * x = " ++ show (y * x)) 33 | > putStrLn ("(x + y) + z = " ++ show ((x + y) + z)) 34 | > putStrLn ("x + (y + z) = " ++ show (x + (y + z))) 35 | > putStrLn ("(x * y) * z = " ++ show ((x * y) * z)) 36 | > putStrLn ("xs = " ++ show xs) 37 | > putStrLn ("sum xs = " ++ show (sum xs)) 38 | 39 | 40 | 41 | -------------------------------------------------------------------------------- /frameworks/14-/TestNonNegRationalBasic1.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import NonNegRational 4 | > import NonNegRationalBasicOperations 5 | > import NonNegRationalBasicProperties 6 | > import Fraction 7 | > import PNat 8 | > import NatPositive 9 | 10 | > %default total 11 | > %auto_implicits off 12 | 13 | 14 | > x : NonNegRational 15 | > x = fromFraction (1, Element 3 MkPositive) 16 | 17 | > y : NonNegRational 18 | > y = fromFraction (1, Element 3 MkPositive) 19 | 20 | > z : NonNegRational 21 | > z = fromFraction (1, Element 3 MkPositive) 22 | 23 | > xs : List NonNegRational 24 | > xs = [x, y, z] 25 | 26 | > sxs : sum xs = fromFraction (1, Element 1 MkPositive) 27 | > sxs = Refl 28 | 29 | -------------------------------------------------------------------------------- /frameworks/14-/TestNonNegRationalBasic2.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import NonNegRational 4 | > import NonNegRationalBasicOperations 5 | > import NonNegRationalBasicProperties 6 | > import Fraction 7 | > import PNat 8 | > import NatPositive 9 | 10 | > %default total 11 | > %auto_implicits off 12 | 13 | 14 | > x : NonNegRational 15 | > x = fromFraction (1, Element 6 MkPositive) 16 | 17 | > y : NonNegRational 18 | > y = fromFraction (2, Element 6 MkPositive) 19 | 20 | > z : NonNegRational 21 | > z = fromFraction (3, Element 6 MkPositive) 22 | 23 | > xs : List NonNegRational 24 | > xs = [x, y, z] 25 | 26 | > sxs : sum xs = fromFraction (1, Element 1 MkPositive) 27 | > sxs = Refl 28 | 29 | -------------------------------------------------------------------------------- /frameworks/14-/TestNonNegRationalBasic3.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import NonNegRational 4 | > import NonNegRationalBasicOperations 5 | > import NonNegRationalBasicProperties 6 | > import Fraction 7 | > import PNat 8 | > import NatPositive 9 | 10 | > %default total 11 | > %auto_implicits off 12 | 13 | > x : NonNegRational 14 | > -- x = fromFraction (2067, Element 616 (MkPositive {n = 615})) 15 | > x = fromFraction (2067, Element 616 MkPositive) 16 | -------------------------------------------------------------------------------- /frameworks/14-/TestNonNegRationalEquality.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import NonNegRational 4 | > import NonNegRationalBasicOperations 5 | > import NonNegRationalBasicProperties 6 | > import Fraction 7 | > import FractionPredicates 8 | > import PNat 9 | > import PNatOperations 10 | > import PNatProperties 11 | > import NatPositive 12 | 13 | > %default total 14 | > %auto_implicits off 15 | 16 | 17 | > f1 : Fraction 18 | > f1 = (1, Element 8 MkPositive) 19 | > z1 : NonNegRational 20 | > z1 = fromFraction f1 21 | 22 | > f2 : Fraction 23 | > f2 = (3, Element 24 MkPositive) 24 | > z2 : NonNegRational 25 | > z2 = fromFraction f2 26 | 27 | > z1EQz2 : z1 = z2 28 | > z1EQz2 = fromFractionEqLemma f1 f2 Refl 29 | 30 | -------------------------------------------------------------------------------- /frameworks/14-/TestNonNegRationalMeasures.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import NonNegRational 4 | > import NonNegRationalBasicOperations 5 | > import NonNegRationalBasicProperties 6 | > import NonNegRationalMeasures 7 | > import Fraction 8 | > import FractionPredicates 9 | > import FractionBasicOperations 10 | > import PNat 11 | > import PNatOperations 12 | > import PNatProperties 13 | > import NatPositive 14 | 15 | > %default total 16 | > %auto_implicits off 17 | 18 | 19 | > f1 : Fraction 20 | > f1 = (1, Element (S 6) (MkPositive {n = 6})) 21 | 22 | > f2 : Fraction 23 | > f2 = (1, Element (S 13) (MkPositive {n = 13})) 24 | 25 | > f3 : Fraction 26 | > f3 = (1, Element (S 17) (MkPositive {n = 17})) 27 | 28 | > f4 : Fraction 29 | > f4 = (2, Element (S 6) (MkPositive {n = 6})) 30 | 31 | > f5 : Fraction 32 | > f5 = (3, Element (S 17) (MkPositive {n = 17})) 33 | 34 | > f6 : Fraction 35 | > f6 = (1, Element (S 13) (MkPositive {n = 13})) 36 | 37 | > f7 : Fraction 38 | > f7 = (2, Element (S 6) (MkPositive {n = 6})) 39 | 40 | > zs : List NonNegRational 41 | > zs = map fromFraction [f1,f1,f1,f1,f1,f1,f1] 42 | 43 | > main : IO () 44 | > main = do putStrLn (show (sum zs)) 45 | > putStrLn (show (average zs)) 46 | 47 | 48 | 49 | -------------------------------------------------------------------------------- /frameworks/14-/TestPNatOperations.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import PNat 4 | > import PNatOperations 5 | > import PNatProperties 6 | > import NatPositive 7 | 8 | > %default total 9 | > %auto_implicits off 10 | 11 | 12 | > x : PNat 13 | > x = Element (S 615) (MkPositive {n = 615}) 14 | 15 | > y : PNat 16 | > y = Element (S 12748) (MkPositive {n = 12748}) 17 | 18 | > main : IO () 19 | > main = do putStrLn ("x = " ++ show x) 20 | > putStrLn ("y = " ++ show y) 21 | > putStrLn ("x + y = " ++ show (x + y)) 22 | > putStrLn ("y + x = " ++ show (y + x)) 23 | > putStrLn ("x * y = " ++ show (x * y)) 24 | > putStrLn ("y * x = " ++ show (y * x)) 25 | 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /frameworks/14-/TestSimpleProbBasic1.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import SimpleProb 4 | > import SimpleProbBasicOperations 5 | > import SimpleProbBasicProperties 6 | > import NonNegRational 7 | > import NonNegRationalBasicOperations 8 | > import NonNegRationalBasicProperties 9 | > import Fraction 10 | > import PNat 11 | > import NatPositive 12 | > import ListOperations 13 | 14 | > %default total 15 | > %auto_implicits off 16 | 17 | > oo2 : NonNegRational 18 | > oo2 = fromFraction (1, Element 2 MkPositive) 19 | 20 | > oo3 : NonNegRational 21 | > oo3 = fromFraction (1, Element 3 MkPositive) 22 | 23 | > sp : SimpleProb Nat 24 | > sp = MkSimpleProb [(0, oo3), (2, oo3), (5, oo3)] Refl 25 | 26 | 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /frameworks/14-/TestSimpleProbBasic2.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import SimpleProb 4 | > import SimpleProbBasicOperations 5 | > import SimpleProbBasicProperties 6 | > import ListOperations 7 | > import NonNegRationalBasicProperties 8 | 9 | > %default total 10 | > %auto_implicits off 11 | 12 | 13 | > xs : List Nat 14 | > xs = [0,1,2,0] 15 | 16 | > sp : SimpleProb Nat 17 | > sp = mkSimpleProb xs () 18 | 19 | > main : IO () 20 | > main = do putStrLn ("sp = " ++ show sp) 21 | > putStrLn ("support sp = " ++ show (support sp)) 22 | > putStrLn ("probs sp = " ++ show (probs sp)) 23 | > putStrLn ("normalize sp = " ++ show (normalize sp)) 24 | > putStrLn ("prob sp 0 = " ++ show (prob sp 0)) 25 | > putStrLn ("prob sp 1 = " ++ show (prob sp 1)) 26 | > putStrLn ("prob sp 2 = " ++ show (prob sp 2)) 27 | > putStrLn ("prob sp 3 = " ++ show (prob sp 3)) 28 | 29 | 30 | 31 | 32 | -------------------------------------------------------------------------------- /frameworks/14-/TotalPreorder.lidr: -------------------------------------------------------------------------------- 1 | > module TotalPreorder 2 | 3 | > import Preorder 4 | 5 | > %default total 6 | 7 | > %access public export 8 | 9 | 10 | > ||| TotalPreorder 11 | > data TotalPreorder : Type -> Type where 12 | > MkTotalPreorder : {A : Type} -> 13 | > (R : A -> A -> Type) -> 14 | > (reflexive : (x : A) -> R x x) -> 15 | > (transitive : (x : A) -> (y : A) -> (z : A) -> R x y -> R y z -> R x z) -> 16 | > (totalPre : (x : A) -> (y : A) -> Either (R x y) (R y x)) -> 17 | > TotalPreorder A 18 | -------------------------------------------------------------------------------- /frameworks/14-/Unique.lidr: -------------------------------------------------------------------------------- 1 | > module Unique -- from an idea by Tim Richter 2 | 3 | > %default total 4 | > %access public export 5 | > %auto_implicits off 6 | 7 | 8 | > Unique : Type -> Type 9 | > Unique t = (p : t) -> (q : t) -> p = q 10 | 11 | > Unique0 : Type -> Type 12 | > Unique0 = Unique 13 | 14 | > Unique1 : {A : Type} -> (A -> Type) -> Type 15 | > Unique1 {A} P = (a : A) -> Unique0 (P a) 16 | 17 | > UniqueEq0 : Type -> Type 18 | > UniqueEq0 A = (a1 : A) -> (a2 : A) -> Unique (a1 = a2) 19 | 20 | > UniqueEq1 : {A : Type} -> (P : A -> Type) -> Type 21 | > UniqueEq1 {A} P = (a : A) -> UniqueEq0 (P a) 22 | 23 | > {- Maybe implement via a type class ? 24 | 25 | > class Unique t where 26 | > unique : (p : t) -> (q : t) -> p = q 27 | 28 | > -} 29 | -------------------------------------------------------------------------------- /frameworks/14-/UnitProperties.lidr: -------------------------------------------------------------------------------- 1 | > module UnitProperties 2 | 3 | 4 | > import Data.Fin 5 | > import Control.Isomorphism 6 | 7 | > import Finite 8 | > import Sigma 9 | > import PairsOperations 10 | 11 | 12 | > %default total 13 | 14 | > %access public export 15 | 16 | 17 | > ||| Mapping |Unit|s to |Fin|s 18 | > toFin : Unit -> Fin (S Z) 19 | > toFin MkUnit = FZ 20 | > -- %freeze toFin 21 | 22 | 23 | > ||| Mapping |Fin (S Z)|s to |Unit|s 24 | > fromFin : Fin (S Z) -> Unit 25 | > fromFin FZ = MkUnit 26 | > fromFin (FS k) = absurd k 27 | > -- %freeze fromFin 28 | 29 | 30 | > ||| |toFin| is the left-inverse of |fromFin| 31 | > toFinFromFinLemma : (k : Fin (S Z)) -> toFin (fromFin k) = k 32 | > toFinFromFinLemma FZ = Refl 33 | > toFinFromFinLemma (FS k) = absurd k 34 | > %freeze toFinFromFinLemma 35 | 36 | 37 | > ||| |fromFin| is the left-inverse of |toFin| 38 | > fromFinToFinLemma : (e : Unit) -> fromFin (toFin e) = e 39 | > fromFinToFinLemma MkUnit = Refl 40 | > %freeze fromFinToFinLemma 41 | 42 | 43 | > ||| Unit is finite 44 | > finiteUnit : Finite Unit 45 | > finiteUnit = MkSigma (S Z) iso where 46 | > iso : Iso Unit (Fin (S Z)) 47 | > iso = MkIso toFin fromFin toFinFromFinLemma fromFinToFinLemma 48 | > %freeze finiteUnit 49 | 50 | 51 | > {- 52 | 53 | > ---} 54 | -------------------------------------------------------------------------------- /frameworks/14-/VoidProperties.lidr: -------------------------------------------------------------------------------- 1 | > module VoidProperties 2 | 3 | 4 | > import Data.Fin 5 | > import Control.Isomorphism 6 | 7 | > import Finite 8 | > import Sigma 9 | 10 | 11 | > %default total 12 | 13 | > %access public export 14 | 15 | 16 | > ||| Mapping |Void|s to |Fin|s 17 | > toFin : Void -> Fin Z 18 | > toFin = void 19 | > %freeze toFin 20 | 21 | 22 | > ||| Mapping |Fin Z|s to |Void|s 23 | > fromFin : Fin Z -> Void 24 | > fromFin k = absurd k 25 | > %freeze fromFin 26 | 27 | 28 | > ||| |toFin| is the left-inverse of |fromFin| 29 | > toFinFromFinLemma : (k : Fin Z) -> toFin (fromFin k) = k 30 | > toFinFromFinLemma k = absurd k 31 | > %freeze toFinFromFinLemma 32 | 33 | 34 | > ||| |fromFin| is the left-inverse of |toFin| 35 | > fromFinToFinLemma : (e : Void) -> fromFin (toFin e) = e 36 | > fromFinToFinLemma e = void e 37 | > %freeze fromFinToFinLemma 38 | 39 | 40 | > ||| Void is finite 41 | > finiteVoid : Finite Void 42 | > finiteVoid = MkSigma Z iso where 43 | > iso : Iso Void (Fin Z) 44 | > iso = MkIso toFin fromFin toFinFromFinLemma fromFinToFinLemma 45 | > %freeze finiteVoid 46 | 47 | 48 | > {- 49 | 50 | > ---} 51 | -------------------------------------------------------------------------------- /frameworks/14-/tests/Makefile: -------------------------------------------------------------------------------- 1 | IDRIS = idris 2 | IDRISFLAGS = -p contrib -p effects -i .. 3 | 4 | all: 5 | find . -name '*.lidr' | xargs -n 1 ${IDRIS} ${IDRISFLAGS} --check 6 | 7 | standardDivMod: standardDivMod.lidr 8 | ${IDRIS} ${IDRISFLAGS} standardDivMod.lidr -o standardDivMod 9 | 10 | nicolaDivMod: nicolaDivMod.lidr 11 | ${IDRIS} ${IDRISFLAGS} nicolaDivMod.lidr -o nicolaDivMod 12 | 13 | melvarDivMod: melvarDivMod.lidr 14 | ${IDRIS} ${IDRISFLAGS} melvarDivMod.lidr -o melvarDivMod 15 | 16 | clean: 17 | -rm -f standardDivMod 18 | -rm -f nicolaDivMod 19 | -rm -f melvarDivMod 20 | -find . -name '*.ibc' -delete 21 | -------------------------------------------------------------------------------- /frameworks/14-/tests/melvarDivMod.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import Effects 4 | > import Effect.Exception 5 | > import Effect.StdIO 6 | 7 | > import Data.Nat.DivMod 8 | 9 | > import EffectException 10 | > import EffectStdIO 11 | 12 | > %default total 13 | 14 | 15 | > divmodNatNZ : (m : Nat) -> (n : Nat) -> Not (n = Z) -> (Nat, Nat) 16 | > divmodNatNZ m Z p = void (p Refl) 17 | > divmodNatNZ m (S n) p with (divMod m n) 18 | > divmodNatNZ (r + q * (S n)) (S n) p | MkDivMod q r rLTm = (q, r) 19 | 20 | > divNatNZ : (m : Nat) -> (n : Nat) -> Not (n = Z) -> Nat 21 | > divNatNZ m n nnZ = fst (divmodNatNZ m n nnZ) 22 | 23 | > modNatNZ : (m : Nat) -> (n : Nat) -> Not (n = Z) -> Nat 24 | > modNatNZ m n nnZ = snd (divmodNatNZ m n nnZ) 25 | 26 | > computation : { [STDIO] } Eff () 27 | > computation = 28 | > do putStr ("enter m:\n") 29 | > m <- getNat 30 | > putStr ("enter n:\n") 31 | > n <- getNat 32 | > case (decEq n Z) of 33 | > (No contra) => do k <- pure (Main.divNatNZ m n contra) 34 | > putStr ("divNatNZ = " ++ show k ++ "\n") 35 | > (Yes p) => putStr ("Error: n = Z\n") 36 | > %freeze computation 37 | 38 | > main : IO () 39 | > main = run computation 40 | > %freeze main 41 | 42 | > ---} 43 | 44 | -- Local Variables: 45 | -- idris-packages: ("effects") 46 | -- End: 47 | -------------------------------------------------------------------------------- /frameworks/14-/tests/standardDivMod.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import Effects 4 | > import Effect.Exception 5 | > import Effect.StdIO 6 | 7 | > import EffectException 8 | > import EffectStdIO 9 | 10 | > %default total 11 | 12 | 13 | > computation : { [STDIO] } Eff () 14 | > computation = 15 | > do putStr ("enter m:\n") 16 | > m <- getNat 17 | > putStr ("enter n:\n") 18 | > n <- getNat 19 | > case (decEq n Z) of 20 | > (No contra) => do k <- pure (divNatNZ m n contra) 21 | > putStr ("divNatNZ = " ++ show k ++ "\n") 22 | > (Yes p) => putStr ("Error: n = Z\n") 23 | > %freeze computation 24 | 25 | > main : IO () 26 | > main = run computation 27 | > %freeze main 28 | 29 | > ---} 30 | 31 | -- Local Variables: 32 | -- idris-packages: ("effects") 33 | -- End: 34 | -------------------------------------------------------------------------------- /frameworks/14-/unused/EmbProj.lidr: -------------------------------------------------------------------------------- 1 | > module EmbProj 2 | 3 | > import Syntax.PreorderReasoning 4 | > import Prop 5 | 6 | > record EmbProj : Type -> Type -> Type where 7 | > MkEmbProj : {A : Type} -> {B : Type} -> 8 | > (to : A -> B) -> 9 | > (from : B -> Maybe A) -> 10 | > (fromTo : (x : A) -> from (to x) = Just x) -> 11 | > EmbProj A B 12 | 13 | > epRefl : {A : Type} -> EmbProj A A 14 | > epRefl = MkEmbProj id Just (\x => Refl) 15 | 16 | > IsInjective : {A : Type} -> {B : Type} -> (to : A -> B) -> Prop 17 | > IsInjective {A} {B} to = (x1, x2 : A) -> (to x1 = to x2) -> (x1 = x2) 18 | 19 | > EmbProjIsInjective : (ep : EmbProj a b) -> IsInjective (to ep) 20 | > EmbProjIsInjective (MkEmbProj to from fromTo) x1 x2 p = 21 | > justInjective ((Just x1) ={ sym (fromTo x1) }= 22 | > (from (to x1)) ={ cong p }= 23 | > (from (to x2)) ={ fromTo x2 }= 24 | > (Just x2) 25 | > QED) 26 | 27 | 28 | > ||| Just is injective 29 | > total justInjective : {x : a} -> {y : a} -> (Just x = Just y) -> (x = y) 30 | > justInjective Refl = Refl 31 | 32 | > -- Alternative definition: 33 | > justIsInjective2 : IsInjective Just 34 | > justIsInjective2 _ _ Refl = Refl 35 | -------------------------------------------------------------------------------- /frameworks/14-/zombies/ClassContainerMonad.lidr: -------------------------------------------------------------------------------- 1 | > module ClassContainerMonad 2 | 3 | 4 | > %default total 5 | 6 | 7 | > record ContainerMonad : Type where 8 | > MkContainerMonad : (M : Type -> Type) -> 9 | > (Elem : {A : Type} -> A -> M A -> Type) -> 10 | > ContainerMonad 11 | 12 | > {- 13 | 14 | > tagElem : (ma : M A) -> M (a : A ** Elem a ma) 15 | 16 | > All : (P : A -> Type) -> M A -> Type 17 | > All {A} P ma = (a : A) -> a `Elem` ma -> P a 18 | 19 | > -} 20 | -------------------------------------------------------------------------------- /frameworks/14-/zombies/ContainerMonad.lidr: -------------------------------------------------------------------------------- 1 | > module ContainerMonad 2 | 3 | 4 | > import Control.Monad.Identity 5 | 6 | 7 | > %default total 8 | 9 | 10 | > class Monad m => ContainerMonad (m : Type -> Type) where 11 | 12 | Requirements: 13 | 14 | > Elem : a -> m a -> Type 15 | > tagElem : (mx : m a) -> m (x : a ** Elem {a = a} x mx) 16 | > All : (a -> Type) -> m a -> Type 17 | 18 | Defaults: 19 | 20 | > ret : a -> m a 21 | > ret = pure 22 | > join : m (m a) -> m a 23 | > join mma = (>>=) mma id 24 | 25 | Specifications: 26 | 27 | > {- TODO: "Can't resolve type class ContainerMonad m" 28 | > spec1 : {a : Type} -> 29 | > {x : a} -> 30 | > Elem {a = a} x (ret {a = a} x) 31 | > spec2 : {x : a} -> {mx : m a} -> {mmx : m (m a)} -> 32 | > Elem {a = a} x mx -> 33 | > Elem {a = m a} mx mmx -> 34 | > Elem {a = a} x (join {a = a} mmx) 35 | > spec3 : {mx : m a} -> map getWitness (tagElem {a = a} mx) = mx 36 | > spec4 : {x : a} -> {mx : m a} -> {P : a -> Type} -> 37 | > All {a = a} P mx -> Elem {a = a} x mx -> P x 38 | > -} 39 | -------------------------------------------------------------------------------- /frameworks/14-/zombies/FractionImplementationIndependentProperties.lidr: -------------------------------------------------------------------------------- 1 | > module FractionImplementationIndependentProperties 2 | 3 | 4 | > import FractionSpecification 5 | 6 | 7 | > %default total 8 | 9 | 10 | The following does not type check! 11 | 12 | > instance Num Fraction where 13 | > (+) = plus 14 | > (*) = mult 15 | > fromInteger = fromNat . fromIntegerNat 16 | 17 | The error message is "Overlapping instance: Num Integer already 18 | defined". I guess this is because of the missing implementations of 19 | |Fraction|, |plus|, |mult| and |fromNat|. 20 | 21 | But there should probably be a way to express the idea that |plus|, 22 | |mult| and |fromNat| are in fact sufficient (with a little help from 23 | |fromIntegerNat|) to make |Fraction| and instance of |Num|. 24 | 25 | 26 | -------------------------------------------------------------------------------- /frameworks/14-/zombies/FractionReduction.lidr: -------------------------------------------------------------------------------- 1 | > module FractionReduction 2 | 3 | 4 | > import Fraction 5 | > import FractionOperations 6 | > import NatCoprime 7 | > import Unique 8 | > import NatGCD 9 | > import NatGCDEuclid 10 | > import PNat 11 | 12 | 13 | > %default total 14 | 15 | 16 | > ||| 17 | > data Reduced : Fraction -> Type where 18 | > MkReduced : {x : Fraction} -> Coprime (num x) (den x) -> Reduced x 19 | 20 | > ||| 21 | > ReducedUnique : {x : Fraction} -> Unique (Reduced x) 22 | > ReducedUnique {x} (MkReduced p) (MkReduced q) = cong (CoprimeUnique p q) 23 | 24 | -------------------------------------------------------------------------------- /frameworks/14-/zombies/LambdaPostulates.lidr: -------------------------------------------------------------------------------- 1 | > module LambdaPostulates 2 | 3 | 4 | > %default total 5 | 6 | 7 | > lambdaLemma1 : {A, B : Type} -> (f : A -> B) -> (\ a => f a) = f 8 | > lambdaLemma1 f = Refl 9 | -------------------------------------------------------------------------------- /frameworks/14-/zombies/NatGCDEuclidStrippedDown.lidr: -------------------------------------------------------------------------------- 1 | > module NatGCDEuclidStrippedDown 2 | 3 | 4 | > import NatOperations 5 | > import NatProperties 6 | 7 | 8 | > %default total 9 | 10 | 11 | Euclid's greatest common divisor algorithm 12 | 13 | 14 | > --{- 15 | > %assert_total 16 | > euclidGCD : (m : Nat) -> (n : Nat) -> Nat 17 | > euclidGCD m Z = m 18 | > euclidGCD Z n = n 19 | > euclidGCD (S m) (S n) with (decLTE (S m) (S n)) 20 | > | (Yes p) = euclidGCD (S m) (S n - S m) 21 | > | (No p) = euclidGCD (S m - S n) (S n) 22 | > ---} 23 | 24 | 25 | > {- 26 | > %assert_total 27 | > euclidGCD : (m : Nat) -> (n : Nat) -> Nat 28 | > euclidGCD m Z = m 29 | > euclidGCD Z n = n 30 | > euclidGCD (S m) (S n) with (decEq m n) 31 | > | (Yes _) = S m 32 | > | (No _) with (decEq (m - n) Z) 33 | > | (Yes _) = euclidGCD (S m) (S n - S m) 34 | > | (No _) = euclidGCD (S m - S n) (S n) 35 | > ---} 36 | 37 | 38 | > {- 39 | > %assert_total 40 | > euclidGCD : (m : Nat) -> (n : Nat) -> Nat 41 | > euclidGCD m Z = m 42 | > euclidGCD Z n = n 43 | > euclidGCD (S m) (S n) = if (S m <= S n) 44 | > then euclidGCD (S m) (S n - S m) 45 | > else euclidGCD (S m - S n) (S n) 46 | > ---} 47 | -------------------------------------------------------------------------------- /frameworks/14-/zombies/NonNegRationalOperations.lidr: -------------------------------------------------------------------------------- 1 | > module NonNegRationalOperations 2 | 3 | 4 | > import NonNegRational 5 | > import Fraction 6 | > import FractionOperations 7 | > import FractionProperties 8 | > import PairsOperations 9 | > import Sigma 10 | 11 | 12 | > %default total 13 | 14 | > %access public export 15 | 16 | 17 | > ||| 18 | > toFraction : NonNegRational -> Fraction 19 | > toFraction = PairsOperations.Subset.getWitness 20 | > -- %freeze toFraction 21 | 22 | 23 | > ||| 24 | > fromFraction : Fraction -> NonNegRational 25 | > fromFraction x = Element (normalize x) (normalNormalize x) 26 | > -- %freeze toFraction 27 | 28 | 29 | > ||| The numerator of a non-negative rational 30 | > num : NonNegRational -> Nat 31 | > num = num . toFraction 32 | > -- %freeze num 33 | 34 | 35 | > ||| The denominator of a non-negative rational 36 | > den : NonNegRational -> Nat 37 | > den = den . toFraction 38 | > -- %freeze den 39 | 40 | 41 | > ||| Every natural number is a non-negative rational 42 | > fromNat : (n : Nat) -> NonNegRational 43 | > fromNat = fromFraction . fromNat 44 | > -- %freeze fromNat 45 | 46 | 47 | > ||| Addition of non-negative rational numbers 48 | > plus : NonNegRational -> NonNegRational -> NonNegRational 49 | > plus x y = fromFraction (toFraction x + toFraction y) 50 | > -- %freeze plus 51 | 52 | 53 | > ||| Multiplication of non-negative rational numbers 54 | > mult : NonNegRational -> NonNegRational -> NonNegRational 55 | > mult x y = fromFraction (toFraction x * toFraction y) 56 | > -- %freeze mult 57 | 58 | 59 | -------------------------------------------------------------------------------- /frameworks/14-/zombies/PreorderOperations.lidr: -------------------------------------------------------------------------------- 1 | > module PreorderOperations 2 | 3 | 4 | > import Preorder 5 | 6 | 7 | > %default total 8 | 9 | 10 | > ||| R 11 | > R : {A : Type} -> Preorder A -> (A -> A -> Type) 12 | > R (MkPreorder R _ _) = R 13 | 14 | 15 | > ||| reflexive 16 | > reflexive : {A : Type} -> 17 | > (tp : Preorder A) -> 18 | > (x : A) -> (R tp) x x 19 | > reflexive (MkPreorder _ reflexive _) = reflexive 20 | 21 | 22 | > ||| transitive 23 | > transitive : {A : Type} -> 24 | > (tp : Preorder A) -> 25 | > (x : A) -> (y : A) -> (z : A) -> (R tp) x y -> (R tp) y z -> (R tp) x z 26 | > transitive (MkPreorder _ _ transitive) = transitive 27 | 28 | 29 | > ||| Preorders on |A| induce preorders on |(A, B)| 30 | > fromPreorder1 : {A, B : Type} -> Preorder A -> Preorder (A, B) 31 | > fromPreorder1 (MkPreorder R reflexive transitive) = 32 | > MkPreorder (\ x => \ y => R (fst x) (fst y)) 33 | > (\ x => reflexive (fst x)) 34 | > (\ x => \ y => \ z => \ xRy => \ yRz => transitive (fst x) (fst y) (fst z) xRy yRz) 35 | 36 | > ||| Preorders on |B| induce preorders on |(A, B)| 37 | > fromPreorder2 : {A, B : Type} -> Preorder B -> Preorder (A, B) 38 | > fromPreorder2 (MkPreorder R reflexive transitive) = 39 | > MkPreorder (\ x => \ y => R (snd x) (snd y)) 40 | > (\ x => reflexive (snd x)) 41 | > (\ x => \ y => \ z => \ xRy => \ yRz => transitive (snd x) (snd y) (snd z) xRy yRz) 42 | -------------------------------------------------------------------------------- /frameworks/14-/zombies/RationalOperations.lidr: -------------------------------------------------------------------------------- 1 | > module RationalOperations 2 | 3 | > import Data.Sign 4 | > import Syntax.PreorderReasoning 5 | 6 | > import RationalSpecification 7 | 8 | 9 | > %default total 10 | 11 | 12 | Constants: 13 | 14 | > zeroQ : Q 15 | > zeroQ = fromIntegerQ 0 16 | 17 | > oneQ : Q 18 | > oneQ = fromIntegerQ 1 19 | 20 | 21 | Operations 22 | 23 | > ||| 24 | > neg : Q -> Q 25 | 26 | > negSpec0 : (q : Q) -> sign q = Zero -> sign (neg q) = Zero 27 | > negSpec1 : (q : Q) -> sign q = Minus -> sign (neg q) = Plus 28 | > negSpec2 : (q : Q) -> sign q = Plus -> sign (neg q) = Minus 29 | 30 | > ||| 31 | > plus : Q -> Q -> Q 32 | 33 | > ||| 34 | > minus : Q -> Q -> Q 35 | 36 | > ||| 37 | > mult : Q -> Q -> Q 38 | 39 | -------------------------------------------------------------------------------- /frameworks/14-/zombies/RationalSpecification.lidr: -------------------------------------------------------------------------------- 1 | > module RationalSpecification 2 | 3 | > import Data.Sign 4 | 5 | > import SignProperties 6 | > import NatPredicates 7 | 8 | 9 | > %default total 10 | > %hide sign 11 | 12 | 13 | > data Q : Type 14 | 15 | > ||| 16 | > public fromIntegerQ : Integer -> Q 17 | 18 | > ||| 19 | > public sign : Q -> Sign 20 | 21 | > ||| 22 | > public numerator : Q -> Nat 23 | 24 | > ||| 25 | > public denominator : Q -> Nat 26 | 27 | > ||| 28 | > public denNotZero : (q : Q) -> Not (denominator q = Z) 29 | 30 | > ||| 31 | > public numDenCoprime : (q : Q) -> Coprime (numerator q) (denominator q) 32 | 33 | > ||| 34 | > public signZero : (q : Q) -> numerator q = Z -> sign q = Zero 35 | 36 | 37 | -------------------------------------------------------------------------------- /frameworks/14-/zombies/RelFloat.lidr: -------------------------------------------------------------------------------- 1 | > module RelFloat 2 | 3 | 4 | > import Data.So 5 | 6 | 7 | > %default total 8 | 9 | 10 | > ||| 11 | > data FloatLTE : Float -> Float -> Type where 12 | > LTE : {x : Float} -> {y : Float} -> So (x <= y) -> FloatLTE x y 13 | 14 | 15 | > ||| 16 | > data FloatLT : Float -> Float -> Type where 17 | > LT : {x : Float} -> {y : Float} -> So (x < y) -> FloatLT x y 18 | -------------------------------------------------------------------------------- /frameworks/14-/zombies/RelFloatPostulates.lidr: -------------------------------------------------------------------------------- 1 | > module RelFloatPostulates 2 | 3 | 4 | > import Data.So 5 | 6 | > import SoProperties 7 | > import RelFloat 8 | 9 | 10 | > %default total 11 | 12 | 13 | FloatLTE properties 14 | 15 | > ||| 16 | > postulate reflexiveFloatLTE : 17 | > (x : Float) -> FloatLTE x x 18 | 19 | 20 | > ||| 21 | > postulate transitiveFloatLTE : 22 | > (x : Float) -> (y : Float) -> (z : Float) -> 23 | > FloatLTE x y -> FloatLTE y z -> FloatLTE x z 24 | 25 | 26 | > ||| 27 | > postulate totalFloatLTE : 28 | > (x : Float) -> (y : Float) -> 29 | > Either (FloatLTE x y) (FloatLTE y x) 30 | 31 | 32 | > ||| 33 | > postulate monotoneFloatPlusLTE : 34 | > {x : Float} -> {y : Float} -> 35 | > (z : Float) -> x `FloatLTE` y -> (z + x) `FloatLTE` (z + y) 36 | -------------------------------------------------------------------------------- /frameworks/14-/zombies/RelFloatProperties.lidr: -------------------------------------------------------------------------------- 1 | > module RelFloatProperties 2 | 3 | 4 | > import Data.So 5 | > import Decidable.Order 6 | 7 | > import Preorder 8 | > import TotalPreorder 9 | > import RelFloat 10 | > import RelFloatPostulates 11 | > import SoProperties 12 | 13 | 14 | > %default total 15 | 16 | 17 | > preorderFloatLTE : Preorder Float 18 | > preorderFloatLTE = 19 | > MkPreorder FloatLTE reflexiveFloatLTE transitiveFloatLTE 20 | 21 | 22 | > totalPreorderFloatLTE : TotalPreorder Float 23 | > totalPreorderFloatLTE = 24 | > MkTotalPreorder FloatLTE reflexiveFloatLTE transitiveFloatLTE totalFloatLTE 25 | -------------------------------------------------------------------------------- /frameworks/14-/zombies/RelSyntax.lidr: -------------------------------------------------------------------------------- 1 | > module RelSyntax 2 | 3 | 4 | > %default total 5 | 6 | 7 | > syntax reflexive [alpha] [r] = 8 | > (a : alpha) -> So (r a a) 9 | 10 | 11 | > syntax transitive [alpha] [r] = 12 | > {a1 : alpha} -> {a2 : alpha} -> {a3 : alpha} -> 13 | > So (r a1 a2) -> So (r a2 a3) -> So (r a1 a3) 14 | 15 | 16 | > syntax monotone [alpha] [r] [op2] = 17 | > {a1 : alpha} -> {a2 : alpha} -> 18 | > (a3 : alpha) -> So (r a1 a2) -> So (r (op2 a3 a1) (op2 a3 a2)) 19 | -------------------------------------------------------------------------------- /frameworks/14-/zombies/SeqDecProbMonadicUtils.lidr: -------------------------------------------------------------------------------- 1 | > module SeqDecProbMonadicUtils 2 | 3 | > import SeqDecProbMonadicTheory 4 | > import Sigma 5 | 6 | 7 | > %default total 8 | > %access public export 9 | > %auto_implicits off 10 | 11 | 12 | > ||| 13 | > showState : {t : Nat} -> X t -> String 14 | 15 | 16 | > ||| 17 | > showCtrl : {t : Nat} -> {x : X t} -> Y t x -> String 18 | 19 | 20 | > ||| 21 | > showStateCtrl : {t : Nat} -> Sigma (X t) (Y t) -> String 22 | > showStateCtrl {t} (MkSigma x y) = "(" ++ showState {t} x ++ " ** " ++ showCtrl {t} {x} y ++ ")" 23 | 24 | 25 | 26 | > using (t : Nat, n : Nat) 27 | > implementation Show (StateCtrlSeq t n) where 28 | > show = show' where 29 | > show' : {t : Nat} -> {n : Nat} -> StateCtrlSeq t n -> String 30 | > show' xys = "[" ++ show'' "" xys ++ "]" where 31 | > show'' : {t' : Nat} -> {n' : Nat} -> String -> StateCtrlSeq t' n' -> String 32 | > show'' {t'} {n' = Z} acc (Nil x) = 33 | > acc ++ "(" ++ showState x ++ " ** " ++ " " ++ ")" 34 | > show'' {t'} {n' = S m'} acc (xy :: xys) = 35 | > show'' {t' = S t'} {n' = m'} (acc ++ showStateCtrl xy ++ ", ") xys 36 | -------------------------------------------------------------------------------- /frameworks/14-/zombies/SignedPredicates.lidr: -------------------------------------------------------------------------------- 1 | > module SignedPredicates 2 | 3 | > import Data.Sign 4 | 5 | 6 | > %default total 7 | 8 | 9 | > NonNeg : (Signed t) => t -> Type 10 | > NonNeg x = Not (sign x = Minus) 11 | 12 | Patrik: TODO: Here it feels a bit backwards to use |Not| when a positive 13 | formulation would be possible. For example, with the natural ordering on 14 | Sign (TODO: define it - probably in Data.Sign in contrib). 15 | 16 | NonNeg q = sign q > Minus 17 | 18 | 19 | 20 | -------------------------------------------------------------------------------- /frameworks/14-/zombies/Util.lidr: -------------------------------------------------------------------------------- 1 | > module Util 2 | 3 | > pair : (a -> b, a -> c) -> a -> (b, c) 4 | > pair (f, g) x = (f x, g x) 5 | -------------------------------------------------------------------------------- /issue_reports/1916_disambiguation.lidr: -------------------------------------------------------------------------------- 1 | > import Data.Vect 2 | 3 | > %default total 4 | 5 | > Dec1 : {A : Type} -> (P : A -> Type) -> Type 6 | > Dec1 {A} P = (a : A) -> Dec (P a) 7 | 8 | > filterTag : {A : Type} -> 9 | > {P : A -> Type} -> 10 | > Dec1 P -> 11 | > Vect n A -> 12 | > (m : Nat ** Vect m (Sigma A P)) 13 | > filterTag d1P Nil = (Z ** Nil) 14 | > filterTag d1P (a :: as) with (filterTag d1P as) 15 | > | (_ ** tail) with (d1P a) 16 | > | (Yes p) = (_ ** (a ** p) :: tail) 17 | > | (No contra) = (_ ** tail) 18 | 19 | > filterTagLemma : {A : Type} -> 20 | > {P : A -> Type} -> 21 | > (d1P : Dec1 P) -> 22 | > (a : A) -> 23 | > (as : Vect n A) -> 24 | > Elem a as -> 25 | > (p : P a) -> 26 | > Elem a (map Sigma.getWitness (getProof (filterTag d1P as))) 27 | 28 | -------------------------------------------------------------------------------- /issue_reports/1928_totality_checker.lidr: -------------------------------------------------------------------------------- 1 | > import Data.Vect 2 | > import Data.Vect.Quantifiers 3 | > import Data.Fin 4 | 5 | > %default total 6 | 7 | > instance Uninhabited (Elem {a} x Nil) where 8 | > uninhabited Here impossible 9 | > uninhabited (There p) impossible 10 | 11 | > lookup : {A : Type} -> 12 | > (a : A) -> (as : Vect n A) -> Elem a as -> Fin n 13 | > lookup a Nil prf = absurd prf 14 | > lookup a (a :: as) Here = FZ 15 | > lookup a (a' :: as) (There prf) = FS (lookup a as prf) 16 | 17 | > indexLookupLemma : {A : Type} -> 18 | > (x : A) -> (xs : Vect n A) -> (prf : Elem x xs) -> 19 | > index (lookup x xs prf) xs = x 20 | > indexLookupLemma x Nil prf = absurd prf 21 | > indexLookupLemma x (x :: xs) Here = Refl 22 | > indexLookupLemma x (x' :: xs) (There prf) = 23 | > let ih = indexLookupLemma x xs prf in rewrite ih in Refl 24 | 25 | > lookupIndexLemma : {A : Type} -> 26 | > (k : Fin n) -> (xs : Vect n A) -> (prf : Elem (index k xs) xs) -> 27 | > lookup (index k xs) xs prf = k 28 | > lookupIndexLemma k Nil prf = absurd prf 29 | > lookupIndexLemma FZ (x :: xs) Here = Refl 30 | > lookupIndexLemma FZ (x :: xs) (There prf) = ?lookupIndexLemma_meta1 31 | > lookupIndexLemma (FS k) (x :: xs) (There prf) = 32 | > let ih = lookupIndexLemma k xs prf in rewrite ih in Refl 33 | 34 | 35 | 36 | -------------------------------------------------------------------------------- /issue_reports/1993_type_classes.lidr: -------------------------------------------------------------------------------- 1 | > import Control.Monad.Identity 2 | > %default total 3 | 4 | > class Monad m => ContainerMonad (m : Type -> Type) where 5 | > Elem : a -> m a -> Type 6 | > ret : a -> m a 7 | > ret = pure 8 | > spec1 : {x : a} -> Elem {a = a} x (ret {a = a} x) 9 | 10 | > instance ContainerMonad Identity where 11 | > Elem a1 (Id a2) = a1 = a2 12 | > spec1 = Refl 13 | -------------------------------------------------------------------------------- /issue_reports/2014_type_classes.lidr: -------------------------------------------------------------------------------- 1 | > import Data.Vect 2 | > import Data.Fin 3 | > import Data.So 4 | > import Decidable.Order 5 | 6 | > %default total 7 | 8 | > class (Preorder t to) => Preordered t (to : t -> t -> Type) | t where 9 | > total preorder : (a : t) -> (b : t) -> Either (to a b) (to b a) 10 | 11 | > instance Uninhabited (LTE (S n) Z) where 12 | > uninhabited LTEZero impossible 13 | > uninhabited (LTESucc x) impossible 14 | 15 | > idSuccPreservesLTE : (m : Nat) -> (n : Nat) -> m `LTE` n -> m `LTE` (S n) 16 | > idSuccPreservesLTE Z n prf = LTEZero 17 | > idSuccPreservesLTE (S m) Z prf = absurd prf 18 | > idSuccPreservesLTE (S m) (S n) prf = LTESucc (idSuccPreservesLTE m n (fromLteSucc prf)) 19 | 20 | > ltZS : (m : Nat) -> LT Z (S m) 21 | > ltZS Z = LTESucc LTEZero 22 | > ltZS (S m) = idSuccPreservesLTE (S Z) (S m) (ltZS m) 23 | 24 | > argmaxMax : {A : Type} -> {TO : A -> A -> Type} -> Preordered A TO => 25 | > Vect n A -> LT Z n -> (Fin n, A) 26 | > argmaxMax {n = Z} Nil p = absurd p 27 | > argmaxMax {n = S Z} (a :: Nil) _ = (FZ, a) 28 | > argmaxMax {A} {n = S (S m)} (a' :: (a'' :: as)) _ with (argmaxMax (a'' :: as) (ltZS m)) 29 | > | (k, max) with (preorder a' max) 30 | > | (Left _) = (FS k, max) 31 | > | (Right _) = (FZ, a') 32 | 33 | -------------------------------------------------------------------------------- /issue_reports/2053_derived_instances.1.lidr: -------------------------------------------------------------------------------- 1 | > class Preorder t (po : t -> t -> Type) where 2 | > total transitive : (a : t) -> (b : t) -> (c : t) -> po a b -> po b c -> po a c 3 | > total reflexive : (a : t) -> po a a 4 | 5 | > instance Preorder a po => Preorder (a,b) (\ ab1 => \ ab2 => po (fst ab1) (fst ab2)) where 6 | > transitive x y z xpoy ypoz = transitive (fst x) (fst y) (fst z) xpoy ypoz 7 | > reflexive x = reflexive (fst x) 8 | -------------------------------------------------------------------------------- /issue_reports/2053_derived_instances.lidr: -------------------------------------------------------------------------------- 1 | > import Decidable.Order 2 | 3 | > instance Preorder a po => Preorder (a,b) (\ ab1 => \ ab2 => po (fst ab1) (fst ab2)) where 4 | > -- transitive x y z xpoy ypoz = transitive (fst x) (fst y) (fst z) xpoy ypoz 5 | > reflexive x = reflexive (fst x) 6 | -------------------------------------------------------------------------------- /issue_reports/2057_type_classes.lidr: -------------------------------------------------------------------------------- 1 | > class Preorder t where 2 | > total po : t -> t -> Type 3 | > total reflexive : (a : t) -> po a a 4 | > total transitive : (a : t) -> (b : t) -> (c : t) -> po a b -> po b c -> po a c 5 | 6 | > instance Preorder a => Preorder (a,b) where 7 | > po a1b1 a2b2 = po (fst a1b1) (fst a2b2) 8 | > reflexive ab = reflexive (fst ab) 9 | > transitive a1b1 a2b2 a3b3 a1poa2 a2poa3 = transitive (fst a1b1) (fst a2b2) (fst a3b3) a1poa2 a2poa3 10 | 11 | 12 | -------------------------------------------------------------------------------- /issue_reports/2058_namespaces.1.lidr: -------------------------------------------------------------------------------- 1 | > namespace lala 2 | > foo : Nat 3 | > namespace lula 4 | > foo : Nat 5 | 6 | > i : Nat 7 | > i = foo 8 | -------------------------------------------------------------------------------- /issue_reports/2058_namespaces.2.lidr: -------------------------------------------------------------------------------- 1 | > class Preorder t where 2 | > total PO : t -> t -> Type 3 | > total reflexive : (x : t) -> PO x x 4 | > total transitive : (x : t) -> (y : t) -> (z : t) -> PO x y -> PO y z -> PO x z 5 | 6 | > namespace lala 7 | > instance Preorder t1 => Preorder (t1, t2) where 8 | > PO x y = PO (fst x) (fst y) 9 | > reflexive x = reflexive (fst x) 10 | > transitive x y z xy yz = transitive (fst x) (fst y) (fst z) xy yz 11 | 12 | > namespace lula 13 | > instance Preorder t2 => Preorder (t1, t2) where 14 | > PO x y = PO (snd x) (snd y) 15 | > reflexive x = reflexive (snd x) 16 | > transitive x y z xy yz = transitive (snd x) (snd y) (snd z) xy yz 17 | 18 | 19 | -------------------------------------------------------------------------------- /issue_reports/2058_namespaces.3.lidr: -------------------------------------------------------------------------------- 1 | > namespace lala 2 | > class Preorder t where 3 | > total PO : t -> t -> Type 4 | > total reflexive : (x : t) -> PO x x 5 | > total transitive : (x : t) -> (y : t) -> (z : t) -> PO x y -> PO y z -> PO x z 6 | 7 | > {- 8 | 9 | > namespace lula 10 | > class Preorder t where 11 | > total PO : t -> t -> Type 12 | > total reflexive : (x : t) -> PO x x 13 | > total transitive : (x : t) -> (y : t) -> (z : t) -> PO x y -> PO y z -> PO x z 14 | 15 | > -} 16 | 17 | -------------------------------------------------------------------------------- /issue_reports/2261_sigma_equality.lidr: -------------------------------------------------------------------------------- 1 | > %default total 2 | 3 | > ||| Introduction 4 | > sigmaEq2 : {A : Type} -> 5 | > {P : A -> Type} -> 6 | > {s1: Sigma A P} -> 7 | > {s2: Sigma A P} -> 8 | > getWitness s1 = getWitness s2 -> 9 | > getProof s1 = getProof s2 -> 10 | > s1 = s2 11 | > -- sigmaEq2 {A} {P} {s1 = (a ** p)} {s2 = (a ** p)} Refl Refl = Refl 12 | > sigmaEq2 {s1=(a ** p)} {s2 = (a' ** p')} pf1 pf2 with (pf1,pf2) 13 | > sigmaEq2 {s1=(a ** p)} {s2 = (a ** p)} pf1 pf2 | (Refl, Refl) = Refl 14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /issue_reports/2322_internal_error.lidr: -------------------------------------------------------------------------------- 1 | > import Data.So 2 | > import Data.Vect 3 | 4 | > %default total 5 | 6 | > data NonNegFloat : Type where 7 | > MkNonNegFloat : (x : Float) -> So (x >= 0.0) -> NonNegFloat 8 | 9 | > instance Cast NonNegFloat Float where 10 | > cast (MkNonNegFloat x _) = x 11 | 12 | > isComponentwiseLE : (Ord alpha) => Vect n alpha -> Vect n alpha -> Bool 13 | > isComponentwiseLE Nil _ = True 14 | > isComponentwiseLE (x :: xs) (y :: ys) = (x <= y) && isComponentwiseLE xs ys 15 | 16 | > NNF_minus_F : (x : Vect n NonNegFloat) -> 17 | > (y : Vect n Float) -> 18 | > So (isComponentwiseLE y (map cast x)) -> 19 | > Vect n NonNegFloat 20 | > NNF_minus_F Nil _ _ = Nil 21 | > NNF_minus_F ((MkNonNegFloat x _) :: xs) (y :: ys) p = (MkNonNegFloat (x - y) (believe_me Oh)) :: (NNF_minus_F xs ys ?p') -- where 22 | > -- z : NonNegFloat 23 | > -- z = (x - y ** believe_me Oh) 24 | 25 | 26 | -------------------------------------------------------------------------------- /issue_reports/2325_show.lidr: -------------------------------------------------------------------------------- 1 | > import Data.Vect 2 | 3 | > data Action = Do | Undo 4 | 5 | > instance Show Action where 6 | > show Do = "Do" 7 | > show Undo = "Undo" 8 | -------------------------------------------------------------------------------- /issue_reports/2325_show_1.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | > import Data.Vect 3 | > u : Vect (S Z) Nat 4 | > u = [Z] 5 | > main : IO () 6 | > main = putStrLn (show (toList u)) 7 | -------------------------------------------------------------------------------- /issue_reports/2326_show.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | > import Data.Vect 3 | > u : Vect (S Z) Nat 4 | > u = [Z] 5 | > main : IO () 6 | > main = putStrLn (show u) 7 | -------------------------------------------------------------------------------- /issue_reports/2986/SimpleProb2986.lidr: -------------------------------------------------------------------------------- 1 | > module SimpleProb2986 2 | 3 | > import NonNegRational 4 | > import NonNegRationalOperations 5 | > import NonNegRationalProperties 6 | 7 | > import NatPositive 8 | > import FractionNormal 9 | > import NumRefinements 10 | > import NumProperties 11 | > import FunOperations 12 | > import ListProperties 13 | 14 | > %default total 15 | > %access public export 16 | 17 | > data SimpleProb : Type -> Type where 18 | > MkSimpleProb : {alpha : Type} -> 19 | > (aps : List (alpha, NonNegRational)) -> 20 | > sum (map snd aps) = 1 -> 21 | > SimpleProb alpha 22 | 23 | > prob : (Eq alpha) => SimpleProb alpha -> alpha -> NonNegRational 24 | > prob (MkSimpleProb aps _) a = foldr f 0 aps where 25 | > f : (alpha, NonNegRational) -> NonNegRational -> NonNegRational 26 | > f (a', p') p = if (a == a') then p + p' else p 27 | > %freeze prob 28 | 29 | > fmap : {A, B : Type} -> (A -> B) -> SimpleProb A -> SimpleProb B 30 | > fmap f (MkSimpleProb aps p) = MkSimpleProb (map (cross f id) aps) ?lula 31 | -------------------------------------------------------------------------------- /issue_reports/3024/Bar.lidr: -------------------------------------------------------------------------------- 1 | > module Bar 2 | > import Foo 3 | > Foo : Type 4 | > Foo = Foo.Foo 5 | 6 | -------------------------------------------------------------------------------- /issue_reports/3024/Bar1.lidr: -------------------------------------------------------------------------------- 1 | > module Bar1 2 | > import Foo 3 | > Foo.b = True 4 | 5 | 6 | -------------------------------------------------------------------------------- /issue_reports/3024/Bar2.lidr: -------------------------------------------------------------------------------- 1 | > module Bar2 2 | > import Foo 3 | > Foo.b = False 4 | 5 | -------------------------------------------------------------------------------- /issue_reports/3024/Foo.lidr: -------------------------------------------------------------------------------- 1 | > module Foo 2 | > public export b : Bool 3 | 4 | -------------------------------------------------------------------------------- /issue_reports/3024/Main.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | > import Foo 3 | > import Bar1 4 | > import Bar2 5 | > a : Bool 6 | > a = b 7 | 8 | -------------------------------------------------------------------------------- /issue_reports/3030/A.lidr: -------------------------------------------------------------------------------- 1 | > module A 2 | > public export a : Bool 3 | 4 | -------------------------------------------------------------------------------- /issue_reports/3030/B.lidr: -------------------------------------------------------------------------------- 1 | > module B 2 | > import A 3 | > A.a = True 4 | -------------------------------------------------------------------------------- /issue_reports/3030/Foo.lidr: -------------------------------------------------------------------------------- 1 | > module A 2 | > public export a : Bool 3 | 4 | -------------------------------------------------------------------------------- /issue_reports/3030/Main.lidr: -------------------------------------------------------------------------------- 1 | > -- import A 2 | > import B 3 | > b : Bool 4 | > b = a 5 | -------------------------------------------------------------------------------- /issue_reports/3031/auto_implicits.1.lidr: -------------------------------------------------------------------------------- 1 | > module Test 2 | > import Data.So 3 | 4 | > %default total 5 | > -- %auto_implicits off 6 | 7 | > Blt : Nat -> Type 8 | > Blt b = (n : Nat ** LT n b) 9 | 10 | > nColumns : Nat 11 | > nColumns = 5 12 | 13 | > valid : Nat -> Blt nColumns -> Bool 14 | > valid t i with (decEq t 3) 15 | > | (Yes _) = fst i > 3 16 | > | (No _) = True 17 | 18 | > State : Nat -> Type 19 | > State t = (i : Blt nColumns ** So (valid t i)) 20 | 21 | > column : {t : Nat} -> State t -> Nat 22 | > column x = fst (fst x) 23 | 24 | > foo : {t : Nat} -> (n : Nat) -> State t -> Bool 25 | > foo {t} n x = 26 | > (n == Z) 27 | > || 28 | > (n == 1 && not (t == 2 && column x < 3)) 29 | > || 30 | > (n == 2 && not ((t == 2 && column x < 3) 31 | > || 32 | > (t == 1 && column x < 2))) 33 | > || 34 | > (n >= 3 && not ((t == 2 && column x < 3) 35 | > || 36 | > (t == 1 && column x < 2) 37 | > || 38 | > (t == 0 && column x < 1))) 39 | 40 | > nSteps : Nat 41 | > nSteps = 4 42 | 43 | > x0 : State Z 44 | > x0 = ((1 ** LTESucc (LTESucc LTEZero)) ** Oh) 45 | 46 | 47 | > v0 : So (foo {t = Z} nSteps x0) 48 | > v0 = Oh 49 | 50 | -------------------------------------------------------------------------------- /issue_reports/3031/auto_implicits.2.lidr: -------------------------------------------------------------------------------- 1 | > module FooMonad 2 | > %default total 3 | > %auto_implicits off 4 | > %access public export 5 | > interface Monad m => FooMonad (m : Type -> Type) where 6 | > Foo : {a : Type} -> a -> m a -> Type 7 | > foo : {a : Type} -> (ma : m a) -> m (DPair a (\ x => Foo x ma)) 8 | 9 | -------------------------------------------------------------------------------- /issue_reports/3031/auto_implicits.lidr: -------------------------------------------------------------------------------- 1 | > import Data.So 2 | 3 | > %default total 4 | > -- %auto_implicits off 5 | 6 | > Foo : Nat -> Type 7 | > Foo b = (n : Nat ** LT n b) 8 | 9 | > foo : Nat -> Foo 5 -> Bool 10 | > foo t i with (decEq t 3) 11 | > | (Yes _) = fst i > 3 12 | > | (No _) = True 13 | 14 | > Bar : Nat -> Type 15 | > Bar t = (i : Foo 5 ** So (foo t i)) 16 | 17 | > bar : {t : Nat} -> (n : Nat) -> Bar t -> Bool 18 | > bar {t} n x = 19 | > (n == Z) 20 | > || 21 | > (n == 1 && not ( t == 2 && fst (fst x) < 3)) 22 | > || 23 | > (n == 2 && not ((t == 2 && fst (fst x) < 3) 24 | > || 25 | > (t == 1 && fst (fst x) < 2))) 26 | > || 27 | > (n >= 3 && not ((t == 2 && fst (fst x) < 3) 28 | > || 29 | > (t == 1 && fst (fst x) < 2) 30 | > || 31 | > (t == 0 && fst (fst x) < 1))) 32 | 33 | > x0 : Bar Z 34 | > x0 = ((1 ** LTESucc (LTESucc LTEZero)) ** Oh) 35 | 36 | > v0 : So (bar {t = Z} 4 x0) 37 | > v0 = Oh 38 | 39 | -------------------------------------------------------------------------------- /issue_reports/3038/BoringParsers.lidr: -------------------------------------------------------------------------------- 1 | > module BoringParsers 2 | 3 | > %access export 4 | 5 | > public export 6 | > A : Type 7 | 8 | > public export 9 | > ParserA : Type 10 | > ParserA = List Char -> Either String (A, List Char) 11 | 12 | > public export 13 | > Parser : Type 14 | > Parser = List Char -> Either String ((), List Char) 15 | 16 | > skipWhile : (Char -> Bool) -> Parser 17 | > skipWhile p [] = Right ((), []) 18 | > skipWhile p (c :: cs) = 19 | > if p c then skipWhile p cs else Right ((), c :: cs) 20 | 21 | > -- wtf: why a 22 | > lexeme : ParserA -> ParserA 23 | > lexeme p cs = do (val, rest) <- p cs 24 | > (_, rest') <- skipWhile (\x => x == ' ' || x == '\t' || x == '\n' || x == '\r') rest 25 | > return (val, rest') 26 | -------------------------------------------------------------------------------- /issue_reports/3079_hide/Decidable.lidr: -------------------------------------------------------------------------------- 1 | > module Decidable 2 | 3 | 4 | > %default total 5 | 6 | > %access public export 7 | 8 | 9 | > Dec0 : Type -> Type 10 | > Dec0 = Dec 11 | 12 | > Dec1 : {A : Type} -> (P : A -> Type) -> Type 13 | > Dec1 {A} P = (a : A) -> Dec0 (P a) 14 | 15 | > DecEq0 : Type -> Type 16 | > DecEq0 A = (a1 : A) -> (a2 : A) -> Dec (a1 = a2) 17 | 18 | > DecEq1 : {A : Type} -> (P : A -> Type) -> Type 19 | > DecEq1 {A} P = (a : A) -> DecEq0 (P a) 20 | -------------------------------------------------------------------------------- /issue_reports/3079_hide/Sigma.lidr: -------------------------------------------------------------------------------- 1 | > module Sigma 2 | 3 | > %default total 4 | 5 | > %access public export 6 | 7 | > %hide Sigma 8 | > %hide MkSigma 9 | 10 | 11 | > data Sigma : (a : Type) -> (P : a -> Type) -> Type where 12 | > MkSigma : .{P : a -> Type} -> (x : a) -> (pf : P x) -> Sigma a P 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | -------------------------------------------------------------------------------- /issue_reports/3079_hide/TestSigma.lidr: -------------------------------------------------------------------------------- 1 | > module VectOperations 2 | 3 | 4 | > import Data.Vect 5 | > -- import Data.Fin 6 | > -- import Data.So 7 | 8 | > import Decidable 9 | > -- import TotalPreorder 10 | > -- import TotalPreorderOperations 11 | > -- import NatProperties 12 | > import Sigma 13 | 14 | 15 | > %default total 16 | 17 | > %access public export 18 | 19 | 20 | Lookup 21 | 22 | > ||| Lookup the index of an element of a vector 23 | > lookup : {A : Type} -> .(a : A) -> .(as : Vect n A) -> Elem a as -> Fin n 24 | > lookup {n = Z} a Nil Here impossible 25 | > lookup {n = Z} a Nil (There p) impossible 26 | > lookup {n = S m} a (a :: as) Here = FZ 27 | > lookup {n = S m} a (a' :: as) (There prf) = FS (lookup a as prf) 28 | 29 | > filter : {A : Type} -> 30 | > {P : A -> Type} -> 31 | > Dec1 P -> 32 | > Vect n A -> 33 | > Sigma Nat (\ m => Vect m A) 34 | > filter d1P Nil = MkSigma Z Nil 35 | > filter d1P (a :: as) with (filter d1P as) 36 | > | (MkSigma n as') with (d1P a) 37 | > | (Yes _) = MkSigma (S n) (a :: as') 38 | > | (No _) = MkSigma n as' 39 | -------------------------------------------------------------------------------- /issue_reports/doubleimport/A.idr: -------------------------------------------------------------------------------- 1 | module A 2 | x : Bool 3 | -------------------------------------------------------------------------------- /issue_reports/doubleimport/B.idr: -------------------------------------------------------------------------------- 1 | module B 2 | import A 3 | A.x = True 4 | -------------------------------------------------------------------------------- /issue_reports/doubleimport/C.idr: -------------------------------------------------------------------------------- 1 | module C 2 | --import A 3 | import B 4 | z : Bool 5 | z = x 6 | -------------------------------------------------------------------------------- /issue_reports/doubleimport/D/A.idr: -------------------------------------------------------------------------------- 1 | module A 2 | export x : Bool 3 | -------------------------------------------------------------------------------- /issue_reports/doubleimport/D/B.idr: -------------------------------------------------------------------------------- 1 | module B 2 | import D.A 3 | A.x = True 4 | -------------------------------------------------------------------------------- /issue_reports/doubleimport/D/C.idr: -------------------------------------------------------------------------------- 1 | module C 2 | --import D.A 3 | import D.B 4 | z : Bool 5 | z = x 6 | -------------------------------------------------------------------------------- /issue_reports/equalitySimple.lidr: -------------------------------------------------------------------------------- 1 | > cong2 : (f : a -> b -> c) -> (a1 = a2) -> (b1 = b2) -> f a1 b1 = f a2 b2 2 | > cong2 f Refl Refl = Refl 3 | 4 | > depCong2 : {alpha : Type} -> 5 | > {P : alpha -> Type} -> 6 | > {a1 : alpha} -> 7 | > {a2 : alpha} -> 8 | > {Pa1 : P a1} -> 9 | > {Pa2 : P a2} -> 10 | > (f : (a : alpha) -> P a -> c) -> 11 | > (a1 = a2) -> 12 | > (Pa1 = Pa2) -> 13 | > f a1 Pa1 = f a2 Pa2 14 | > depCong2 f Refl Refl = Refl 15 | 16 | > postulate lala : (b : Nat) -> (i : Nat) -> (j : Nat) -> 17 | > (p : LT i b) -> (q : LT j b) -> i = j -> p = q 18 | 19 | > P : Nat -> Type 20 | > P n = LT n 5 21 | 22 | > T : Type 23 | > T = Sigma Nat P 24 | 25 | > i : Nat 26 | > i = Z 27 | 28 | > j : Nat 29 | > j = Z 30 | 31 | > p : P i 32 | > q : P j 33 | 34 | > m : T 35 | > m = (i ** p) 36 | 37 | > n : T 38 | > n = (j ** q) 39 | 40 | > peq : p = q 41 | > peq = lala 5 i j p q Refl 42 | 43 | > r : m = n 44 | > r = depCong2 {alpha = Nat} 45 | > {P = P} 46 | > {a1 = i} 47 | > {a2 = j} 48 | > {Pa1 = p} 49 | > {Pa2 = q} 50 | > MkSigma Refl peq 51 | 52 | 53 | -------------------------------------------------------------------------------- /issue_reports/equalitySimpler.lidr: -------------------------------------------------------------------------------- 1 | > cong2 : (f : a -> b -> c) -> (a1 = a2) -> (b1 = b2) -> f a1 b1 = f a2 b2 2 | > cong2 f Refl Refl = Refl 3 | 4 | > depCong2 : {alpha : Type} -> 5 | > {P : alpha -> Type} -> 6 | > {a1 : alpha} -> 7 | > {a2 : alpha} -> 8 | > {Pa1 : P a1} -> 9 | > {Pa2 : P a2} -> 10 | > (f : (a : alpha) -> P a -> c) -> 11 | > (a1 = a2) -> 12 | > (Pa1 = Pa2) -> 13 | > f a1 Pa1 = f a2 Pa2 14 | > depCong2 f Refl Refl = Refl 15 | 16 | > P : Nat -> Type 17 | > P n = LT n 5 18 | 19 | > T : Type 20 | > T = Sigma Nat P 21 | 22 | > p : P Z 23 | > p = LTESucc LTEZero 24 | 25 | > m : T 26 | > m = (Z ** p) 27 | 28 | > n : T 29 | > n = (Z ** p) 30 | 31 | > q : m = n 32 | > q = depCong2 MkSigma Refl Refl 33 | 34 | 35 | -------------------------------------------------------------------------------- /issue_reports/filterTag.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import Data.Vect 4 | > import Effects 5 | > import Effect.Exception 6 | > import Effect.StdIO 7 | > import Decidable.Order 8 | 9 | > %default total 10 | 11 | > Dec1 : {A : Type} -> (P : A -> Type) -> Type 12 | > Dec1 {A} P = (a : A) -> Dec (P a) 13 | 14 | > ||| Filters a vector on a decidable property and pairs elements with proofs 15 | > filterTag : {A : Type} -> 16 | > {P : A -> Type} -> 17 | > Dec1 P -> 18 | > Vect n A -> 19 | > Sigma Nat (\ m => Vect m (Sigma A P)) 20 | > filterTag d1P Nil = (Z ** Nil) 21 | > filterTag d1P (a :: as) with (filterTag d1P as) 22 | > | (_ ** tail) with (d1P a) 23 | > | (Yes p) = (_ ** (a ** p) :: tail) 24 | > | (No contra) = (_ ** tail) 25 | 26 | > v : Vect 5 Nat 27 | > v = [1,2,3,0,5] 28 | 29 | > P : Nat -> Type 30 | > P n = LTE n 2 31 | 32 | > dP : (n : Nat) -> Dec (P n) 33 | > dP n = lte n 2 34 | 35 | > v' : (n : Nat ** Vect n (Sigma Nat P)) 36 | > v' = filterTag dP v 37 | 38 | 39 | > computation : { [STDIO] } Eff () 40 | > computation = 41 | > do putStrLn (show v) 42 | > v' <- pure (map Sigma.getWitness (Sigma.getProof v')) 43 | > putStrLn (show v') 44 | 45 | > main : IO () 46 | > main = run computation 47 | -------------------------------------------------------------------------------- /issue_reports/num_type_mismatch/Fraction.lidr: -------------------------------------------------------------------------------- 1 | > module Fraction 2 | 3 | 4 | > import PNat 5 | 6 | 7 | > %default total 8 | > %access public export 9 | 10 | 11 | > ||| Fraction representation 12 | > Fraction : Type 13 | > Fraction = (Nat, PNat) 14 | 15 | 16 | -------------------------------------------------------------------------------- /issue_reports/num_type_mismatch/FractionNormal.lidr: -------------------------------------------------------------------------------- 1 | > module FractionNormal 2 | 3 | > import Fraction 4 | 5 | 6 | > %default total 7 | > %access public export 8 | 9 | 10 | > data Normal : Fraction -> Type where 11 | > MkNormal : {x : Fraction} -> Normal x 12 | 13 | 14 | -------------------------------------------------------------------------------- /issue_reports/num_type_mismatch/FractionOperations.lidr: -------------------------------------------------------------------------------- 1 | > module FractionOperations 2 | 3 | 4 | > import Fraction 5 | > import PNat 6 | > import PNatOperations 7 | > import PNatProperties 8 | > import NatPositive 9 | 10 | 11 | > %default total 12 | > %access public export 13 | 14 | 15 | > ||| The numerator of a fraction 16 | > num : Fraction -> Nat 17 | > num = fst 18 | > -- %freeze num 19 | 20 | 21 | > ||| The denominator of a fraction 22 | > den : Fraction -> Nat 23 | > den = toNat . snd 24 | > -- %freeze den 25 | 26 | 27 | > ||| Every natural number is a fraction 28 | > fromNat : Nat -> Fraction 29 | > fromNat n = (n, Element (S Z) MkPositive) 30 | > -- %freeze fromNat 31 | 32 | 33 | > ||| Fraction addition 34 | > plus : Fraction -> Fraction -> Fraction 35 | > plus (n1, d1) (n2, d2) = (n1 * (toNat d2) + n2 * (toNat d1), d1 * d2) 36 | > -- %freeze plus 37 | 38 | 39 | > ||| Fraction multiplication 40 | > mult : Fraction -> Fraction -> Fraction 41 | > mult (n1, d1) (n2, d2) = (n1 * n2, d1 * d2) 42 | > -- %freeze mult 43 | 44 | 45 | -------------------------------------------------------------------------------- /issue_reports/num_type_mismatch/FractionProperties.lidr: -------------------------------------------------------------------------------- 1 | > module FractionProperties 2 | 3 | > import Fraction 4 | > import FractionOperations 5 | > import FractionNormal 6 | > import NatPositive 7 | 8 | 9 | > %default total 10 | > %access public export 11 | 12 | 13 | > ||| Fraction is an instance of Num 14 | > implementation Num Fraction where 15 | > (+) = plus 16 | > (*) = mult 17 | > fromInteger = fromNat . fromIntegerNat 18 | 19 | 20 | -------------------------------------------------------------------------------- /issue_reports/num_type_mismatch/Makefile: -------------------------------------------------------------------------------- 1 | IDRIS = idris 2 | IDRISFLAGS = +RTS -K32000000 -RTS -p contrib -p effects --warnreach -V 3 | 4 | issue: Fraction.lidr \ 5 | FractionNormal.lidr \ 6 | FractionOperations.lidr \ 7 | FractionProperties.lidr \ 8 | NatPositive.lidr \ 9 | NonNegRational.lidr \ 10 | NonNegRationalOperations.lidr \ 11 | NonNegRationalProperties.lidr \ 12 | NonNegRationalTest.lidr \ 13 | PNat.lidr \ 14 | PNatOperations.lidr \ 15 | PNatProperties.lidr 16 | ${IDRIS} ${IDRISFLAGS} NonNegRationalTest.lidr 17 | 18 | clean: 19 | -find . -name '*.ibc' -delete 20 | -------------------------------------------------------------------------------- /issue_reports/num_type_mismatch/NatPositive.lidr: -------------------------------------------------------------------------------- 1 | > module NatPositive 2 | 3 | 4 | > %default total 5 | 6 | > %access public export 7 | 8 | 9 | > data Positive : Nat -> Type where 10 | > MkPositive : {n : Nat} -> Positive (S n) 11 | 12 | 13 | > plusPreservesPositivity : Positive m -> Positive n -> Positive (m + n) 14 | > plusPreservesPositivity {m = Z } {n } MkPositive _ impossible 15 | > plusPreservesPositivity {m } {n = Z } _ MkPositive impossible 16 | > plusPreservesPositivity {m = S m} {n = S n} _ _ = MkPositive 17 | 18 | 19 | > multPreservesPositivity : Positive m -> Positive n -> Positive (m * n) 20 | > multPreservesPositivity {m = Z } {n } MkPositive _ impossible 21 | > multPreservesPositivity {m } {n = Z } _ MkPositive impossible 22 | > multPreservesPositivity {m = S m} {n = S n} _ _ = MkPositive 23 | 24 | 25 | -------------------------------------------------------------------------------- /issue_reports/num_type_mismatch/NonNegRational.lidr: -------------------------------------------------------------------------------- 1 | > module NonNegRational 2 | 3 | 4 | > import Fraction 5 | > import FractionNormal 6 | 7 | 8 | > %default total 9 | > %access public export 10 | 11 | 12 | > ||| Non negative rational numbers 13 | > NonNegRational : Type 14 | > NonNegRational = Subset Fraction Normal 15 | 16 | 17 | -------------------------------------------------------------------------------- /issue_reports/num_type_mismatch/NonNegRationalOperations.lidr: -------------------------------------------------------------------------------- 1 | > module NonNegRationalOperations 2 | 3 | 4 | > import NonNegRational 5 | > import Fraction 6 | > import FractionOperations 7 | > import FractionProperties 8 | > import FractionNormal 9 | > import NatPositive 10 | 11 | 12 | > %default total 13 | > %access public export 14 | 15 | 16 | > ||| 17 | > toFraction : NonNegRational -> Fraction 18 | > toFraction = getWitness 19 | > -- %freeze toFraction 20 | 21 | 22 | > ||| 23 | > fromFraction : Fraction -> NonNegRational 24 | > fromFraction x = Element x MkNormal 25 | > -- %freeze toFraction 26 | 27 | 28 | > ||| The numerator of a non-negative rational 29 | > num : NonNegRational -> Nat 30 | > num = num . toFraction 31 | > -- %freeze num 32 | 33 | 34 | > ||| The denominator of a non-negative rational 35 | > den : NonNegRational -> Nat 36 | > den = den . toFraction 37 | > -- %freeze den 38 | 39 | 40 | > ||| Every natural number is a non-negative rational 41 | > fromNat : (n : Nat) -> NonNegRational 42 | > fromNat = fromFraction . fromNat 43 | > -- %freeze fromNat 44 | 45 | 46 | > ||| Addition of non-negarive rational numbers 47 | > plus : NonNegRational -> NonNegRational -> NonNegRational 48 | > plus x y = fromFraction (toFraction x + toFraction y) 49 | > -- %freeze plus 50 | 51 | 52 | > ||| Multiplication of non-negarive rational numbers 53 | > mult : NonNegRational -> NonNegRational -> NonNegRational 54 | > mult x y = fromFraction (toFraction x * toFraction y) 55 | > -- %freeze mult 56 | 57 | -------------------------------------------------------------------------------- /issue_reports/num_type_mismatch/NonNegRationalProperties.lidr: -------------------------------------------------------------------------------- 1 | > module NonNegRationalProperties 2 | 3 | 4 | > import NonNegRational 5 | > import NonNegRationalOperations 6 | > import Fraction 7 | > import FractionNormal 8 | > import NatPositive 9 | 10 | 11 | > %default total 12 | > %access public export 13 | 14 | 15 | > ||| NonNegRational is an implementation of Show 16 | > implementation Show NonNegRational where 17 | > show q = show (num q) ++ "/" ++ show (den q) 18 | 19 | 20 | > ||| NonNegRational is an implementation of Num 21 | > implementation Num NonNegRational where 22 | > (+) = plus 23 | > (*) = mult 24 | > fromInteger = fromNat . fromIntegerNat 25 | 26 | 27 | -------------------------------------------------------------------------------- /issue_reports/num_type_mismatch/NonNegRationalTest.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import NonNegRational 4 | > import NonNegRationalOperations 5 | > import NonNegRationalProperties 6 | > import Fraction 7 | > import FractionOperations 8 | > import PNat 9 | > import PNatOperations 10 | > import PNatProperties 11 | > import NatPositive 12 | 13 | 14 | > %default total 15 | 16 | 17 | > x : NonNegRational 18 | > x = fromFraction (2067, Element 616 MkPositive) 19 | 20 | > y : NonNegRational 21 | > y = fromFraction (32, Element 11 MkPositive) 22 | 23 | > z : NonNegRational 24 | > -- z = x `plus` y 25 | > z = x + y 26 | 27 | > main : IO () 28 | > main = do putStrLn (show z) 29 | 30 | 31 | -------------------------------------------------------------------------------- /issue_reports/num_type_mismatch/PNat.lidr: -------------------------------------------------------------------------------- 1 | > module PNat 2 | 3 | 4 | > import Syntax.PreorderReasoning 5 | 6 | > import NatPositive 7 | 8 | 9 | > %default total 10 | > %access public export 11 | 12 | 13 | > ||| Positive natural numbers as sigma types 14 | > PNat : Type 15 | > PNat = Subset Nat Positive 16 | 17 | -------------------------------------------------------------------------------- /issue_reports/num_type_mismatch/PNatOperations.lidr: -------------------------------------------------------------------------------- 1 | > module PNat 2 | 3 | 4 | > import PNat 5 | > import NatPositive 6 | 7 | 8 | > %default total 9 | > %access public export 10 | 11 | 12 | > ||| 13 | > toNat : PNat -> Nat 14 | > toNat = getWitness 15 | 16 | 17 | > ||| 18 | > plus : PNat -> PNat -> PNat 19 | > plus (Element m pm) (Element n pn) = Element (m + n) (plusPreservesPositivity pm pn) 20 | 21 | 22 | > ||| 23 | > (+) : PNat -> PNat -> PNat 24 | > (+) = plus 25 | 26 | 27 | > ||| 28 | > mult : PNat -> PNat -> PNat 29 | > mult (Element m pm) (Element n pn) = Element (m * n) (multPreservesPositivity pm pn) 30 | 31 | 32 | > ||| 33 | > (*) : PNat -> PNat -> PNat 34 | > (*) = mult 35 | 36 | -------------------------------------------------------------------------------- /issue_reports/num_type_mismatch/PNatProperties.lidr: -------------------------------------------------------------------------------- 1 | > module PNat 2 | 3 | > import PNat 4 | > import PNatOperations 5 | > import NatPositive 6 | 7 | 8 | > %default total 9 | > %access public export 10 | 11 | 12 | > ||| PNat is an instance of Show 13 | > implementation Show PNat where 14 | > show = show . toNat 15 | 16 | -------------------------------------------------------------------------------- /issue_reports/totalityChecker.lidr: -------------------------------------------------------------------------------- 1 | > import Data.Fin 2 | > import Data.Vect 3 | 4 | > total 5 | > Dec1 : {A : Type} -> (P : A -> Type) -> Type 6 | > Dec1 {A} P = (a : A) -> Dec (P a) 7 | 8 | > instance Uninhabited (Elem {a} x Nil) where 9 | > uninhabited Here impossible 10 | > uninhabited (There p) impossible 11 | 12 | > total 13 | > filter : {A : Type} -> 14 | > {P : A -> Type} -> 15 | > Dec1 P -> 16 | > Vect n A -> 17 | > (m : Nat ** Vect m A) 18 | > filter d1P Nil = (Z ** Nil) 19 | > filter d1P (a :: as) with (filter d1P as) 20 | > | (_ ** tail) with (d1P a) 21 | > | (Yes p) = (_ ** a :: tail) 22 | > | (No contra) = (_ ** tail) 23 | 24 | > total 25 | > filterLemma : {A : Type} -> 26 | > {P : A -> Type} -> 27 | > (d1P : Dec1 P) -> 28 | > (a : A) -> 29 | > (as : Vect n A) -> 30 | > Elem a as -> 31 | > (p : P a) -> 32 | > Elem a (getProof (filter d1P as)) 33 | > filterLemma d1P a Nil prf p = absurd prf -- impossible 34 | 35 | 36 | -------------------------------------------------------------------------------- /issue_reports/totalityChecker1.lidr: -------------------------------------------------------------------------------- 1 | > import Data.Vect 2 | > import Data.Vect.Quantifiers 3 | > import Data.Fin 4 | 5 | > %default total 6 | 7 | > instance Uninhabited (Elem {a} x Nil) where 8 | > uninhabited Here impossible 9 | > uninhabited (There p) impossible 10 | 11 | > lookup : {A : Type} -> 12 | > (a : A) -> (as : Vect n A) -> Elem a as -> Fin n 13 | > lookup a Nil prf = absurd prf 14 | > lookup a (a :: as) Here = FZ 15 | > lookup a (a' :: as) (There prf) = FS (lookup a as prf) 16 | 17 | > indexLookupLemma : {A : Type} -> 18 | > (x : A) -> (xs : Vect n A) -> (prf : Elem x xs) -> 19 | > index (lookup x xs prf) xs = x 20 | > indexLookupLemma x Nil prf = absurd prf 21 | > indexLookupLemma x (x :: xs) Here = Refl 22 | > indexLookupLemma x (x' :: xs) (There prf) = 23 | > let ih = indexLookupLemma x xs prf in rewrite ih in Refl 24 | 25 | > lookupIndexLemma : {A : Type} -> 26 | > (k : Fin n) -> (xs : Vect n A) -> (prf : Elem (index k xs) xs) -> 27 | > lookup (index k xs) xs prf = k 28 | > lookupIndexLemma k Nil prf = absurd prf 29 | > lookupIndexLemma FZ (x :: xs) Here = Refl 30 | > lookupIndexLemma FZ (x :: xs) (There prf) = ?lookupIndexLemma_meta1 31 | > lookupIndexLemma (FS k) (x :: xs) (There prf) = 32 | > let ih = lookupIndexLemma k xs prf in rewrite ih in Refl 33 | 34 | 35 | 36 | -------------------------------------------------------------------------------- /issue_reports/typeClasses.lidr: -------------------------------------------------------------------------------- 1 | > class Monad m => ContainerMonad (m : Type -> Type) where 2 | > Elem : a -> m a -> Type 3 | > tagElem : (mx : m a) -> m (x : a ** Elem {a = a} x mx) 4 | 5 | -------------------------------------------------------------------------------- /issue_reports/typeClasses1.lidr: -------------------------------------------------------------------------------- 1 | > -- Lala : Nat -> Type 2 | > -- Lala n = Nat 3 | 4 | > Elem : (M : Nat -> Type) -> (n : Nat)-> M n -> Type 5 | > Elem Lala m n = m = n 6 | 7 | 8 | 9 | 10 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/.gitignore: -------------------------------------------------------------------------------- 1 | example 2 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Bool/Postulates.lidr: -------------------------------------------------------------------------------- 1 | > module Postulates 2 | 3 | > import Data.So 4 | 5 | > import Rel.Syntax 6 | 7 | 8 | > postulate reflexive_Bool_eqeq : reflexive Bool (==) 9 | 10 | > postulate symmetric_Bool_eqeq : symmetric Bool (==) 11 | 12 | > postulate transitive_Bool_eqeq : transitive Bool (==) 13 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/BoundedNat/Blt.lidr: -------------------------------------------------------------------------------- 1 | > module Blt 2 | 3 | > import Data.So 4 | > import Data.Vect 5 | 6 | > import Nat.Properties 7 | > import Logic.Properties 8 | > import Exists.Ops 9 | 10 | 11 | > %default total 12 | 13 | > %access public export 14 | 15 | 16 | 17 | > Blt : Nat -> Type 18 | > Blt b = (n : Nat ** LT n b) 19 | 20 | > BltLemma0 : Blt Z -> alpha 21 | > BltLemma0 (n ** p) = absurd p 22 | 23 | > toNat : Blt b -> Nat 24 | > toNat = outl 25 | 26 | > toDouble : Blt b -> Double 27 | > toDouble i = cast {from = Int} {to = Double} (cast {from = Nat} {to = Int} (Blt.toNat i)) 28 | 29 | > using (p : Nat -> Type) 30 | > Prelude.Show.Show (n : Nat ** p n) where 31 | > show (n ** _) = show n 32 | 33 | > using (p : Nat -> Type) 34 | > Eq (n : Nat ** p n) where 35 | > (==) (n ** _) (n' ** _) = n == n' 36 | 37 | > partial 38 | > decBlt : Blt b -> Blt b 39 | > decBlt {b} (S k ** q) = (k ** ltLemma1 k b q) 40 | 41 | > incBlt : (n : Blt b) -> LT (S (Blt.toNat n)) b -> Blt b 42 | > incBlt (k ** _) q = (S k ** q) 43 | 44 | > toVect : {b : Nat} -> (Blt b -> a) -> Vect b a 45 | > toVect {b = Z} _ = Nil 46 | > toVect {b = S b'} {a = a} f = ((f (Z ** ltZS b')) :: toVect f') where 47 | > f' : Blt b' -> a 48 | > f' (k ** q) = f (S k ** LTESucc q) 49 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Double/Double.lidr: -------------------------------------------------------------------------------- 1 | > module Double 2 | 3 | 4 | > import Data.So 5 | 6 | > import Exists.Ops 7 | 8 | 9 | > %default total 10 | 11 | 12 | > ||| Non negative |Double|s 13 | > data NonNegDouble : Type where 14 | > MkNonNegDouble : (x : Double) -> So (x >= 0.0) -> NonNegDouble 15 | 16 | > Cast NonNegDouble Double where 17 | > cast (MkNonNegDouble x _) = x 18 | 19 | 20 | > ||| |Double|s in [a,b] 21 | > data GeLeDouble : Double -> Double -> Type where 22 | > MkGeLeDouble : {a : Double} -> {b : Double} -> 23 | > (x : Double) -> So (a <= x) -> So (x <= b) -> GeLeDouble a b 24 | 25 | > using (a, b : Double) 26 | > Cast (GeLeDouble a b) Double where 27 | > cast (MkGeLeDouble x _ _) = x 28 | 29 | 30 | > ||| 31 | > data GeDouble : Double -> Type where 32 | > MkGeDouble : {a : Double} -> (x : Double) -> So (a <= x) -> GeDouble a 33 | 34 | > using (a : Double) 35 | > Cast (GeDouble a) Double where 36 | > cast (MkGeDouble x _) = x 37 | 38 | 39 | > ||| 40 | > data LeDouble : Double -> Type where 41 | > MkLeDouble : {a : Double} -> (x : Double) -> So (x <= a) -> LeDouble a 42 | 43 | > using (a : Double) 44 | > Cast (LeDouble a) Double where 45 | > cast (MkLeDouble x _) = x 46 | 47 | 48 | 49 | > using (p : Double -> Type) 50 | > Show (x : Double ** p x) where 51 | > show (x ** _) = show x 52 | 53 | > using (p : Double -> Type) 54 | > Eq (x : Double ** p x) where 55 | > (==) (x ** _) (y ** _) = x == y 56 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Double/Postulates.lidr: -------------------------------------------------------------------------------- 1 | > module Postulates 2 | 3 | > import Data.So 4 | 5 | > import Rel.Syntax 6 | 7 | > %default total 8 | 9 | > %access public export 10 | 11 | 12 | > postulate sub_Double_eqeq_lte : sub Double (==) (<=) 13 | 14 | > postulate sub_Double_lt_lte : sub Double (<) (<=) 15 | 16 | > postulate reflexive_Double_eqeq : reflexive Double (==) 17 | 18 | > postulate symmetric_Double_eqeq : symmetric Double (==) 19 | 20 | > postulate transitive_Double_lte : transitive Double (<=) 21 | 22 | > postulate monotone_Double_plus_lte : monotone Double (+) (<=) 23 | 24 | > postulate monotone'_Double_plus_lte : monotone' Double (+) (<=) 25 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Double/Properties.lidr: -------------------------------------------------------------------------------- 1 | > module Properties 2 | 3 | > import Data.So 4 | 5 | > import Rel.Syntax 6 | > import Double.Postulates 7 | 8 | > %default total 9 | 10 | > %access public export 11 | 12 | 13 | > reflexive_Double_lte : reflexive Double (<=) 14 | > reflexive_Double_lte x = sub_Double_eqeq_lte (reflexive_Double_eqeq x) 15 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/DynamicProgramming/S1101_Context.lidr: -------------------------------------------------------------------------------- 1 | > module Context 2 | 3 | > %default total 4 | 5 | 6 | > State : Type 7 | > Ctrl : (x : State) -> Type 8 | > step : (x : State) -> (y : Ctrl x) -> State 9 | > reward : (x : State) -> (y : Ctrl x) -> (x' : State) -> Double 10 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/DynamicProgramming/S1102_OptimalControls.lidr: -------------------------------------------------------------------------------- 1 | > module OptimalControls 2 | 3 | > import Data.So 4 | 5 | > import Double.Properties 6 | > import DynamicProgramming.S1101_Context 7 | 8 | > %default total 9 | 10 | 11 | > data CtrlSeq : State -> Nat -> Type where 12 | > Nil : CtrlSeq x Z 13 | > (::) : (y : Ctrl x) -> CtrlSeq (step x y) n -> CtrlSeq x (S n) 14 | 15 | > value : {x : State} -> {n : Nat} -> CtrlSeq x n -> Double 16 | > value {n = Z} _ = 0 17 | > value {x} {n = S m} (y :: ys) = reward x y (step x y) + value ys 18 | 19 | > OptCtrlSeq : {x : State} -> {n : Nat} -> CtrlSeq x n -> Type 20 | > OptCtrlSeq {x} {n} ys = (ys' : CtrlSeq x n) -> So (value ys' <= value ys) 21 | 22 | > nilIsOptCtrlSeq : (x : State) -> OptCtrlSeq {x} Nil 23 | > nilIsOptCtrlSeq x ys' = reflexive_Double_lte 0 24 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/DynamicProgramming/S1104_MaxArgmax.lidr: -------------------------------------------------------------------------------- 1 | > module MaxArgmax 2 | 3 | > import Data.So 4 | 5 | > import DynamicProgramming.S1101_Context 6 | 7 | > %default total 8 | 9 | 10 | > max : (x : State) -> (Ctrl x -> Double) -> Double 11 | > argmax : (x : State) -> (Ctrl x -> Double) -> Ctrl x 12 | 13 | > MaxSpec : Type 14 | > MaxSpec = (x : State) -> (f : Ctrl x -> Double) -> (y : Ctrl x) -> 15 | > So (f y <= max x f) 16 | > ArgmaxSpec : Type 17 | > ArgmaxSpec = (x : State) -> (f : Ctrl x -> Double) -> 18 | > So (f (argmax x f) == max x f) 19 | 20 | Thas is, we assume to be able to define |maxSpec| and |argmaxSpec| of 21 | type |MaxSpec|, |ArgmaxSpec|, respectively: 22 | 23 | > maxSpec : MaxSpec 24 | > argmaxSpec : ArgmaxSpec 25 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/DynamicProgramming/S1201_Context.lidr: -------------------------------------------------------------------------------- 1 | > module Context 2 | 3 | 4 | > %default total 5 | 6 | > %access public export 7 | 8 | 9 | > State : (t : Nat) -> Type 10 | > Ctrl : (t : Nat) -> State t -> Type 11 | > step : (t : Nat) -> (x : State t) -> Ctrl t x -> State (S t) 12 | > reward : (t : Nat) -> (x : State t) -> Ctrl t x -> State (S t) -> Double 13 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/DynamicProgramming/S1202_ReachabilityViability.lidr: -------------------------------------------------------------------------------- 1 | > module ReachabilityViability 2 | 3 | > import Data.So 4 | 5 | > import Util.VectExtensions1 6 | > import DynamicProgramming.S1201_Context 7 | 8 | > %default total 9 | 10 | > %access public export 11 | 12 | 13 | > reachable : State t -> Bool 14 | > Reachable : State t -> Type 15 | 16 | > Reachable x = So (reachable x) 17 | 18 | > reachableSpec0 : (x : State Z) -> Reachable x 19 | > reachableSpec1 : (x : State t) -> Reachable x -> (y : Ctrl t x) -> Reachable (step t x y) 20 | > reachableSpec2 : (x' : State (S t)) -> Reachable x' -> 21 | > (x : State t ** (Reachable x , (y : Ctrl t x ** x' = step t x y))) 22 | 23 | > viable : (n : Nat) -> State t -> Bool 24 | 25 | > Viable : (n : Nat) -> State t -> Type 26 | > Viable n x = So (viable n x) 27 | 28 | > GoodCtrl : (t : Nat) -> (n : Nat) -> State t -> Type 29 | > GoodCtrl t n x = (y : Ctrl t x ** Viable n (step t x y)) 30 | 31 | > viableSpec0 : (x : State t) -> Viable Z x 32 | > viableSpec1 : (x : State t) -> Viable (S n) x -> GoodCtrl t n x 33 | > viableSpec2 : (x : State t) -> GoodCtrl t n x -> Viable (S n) x 34 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/DynamicProgramming/S1203_Controls.lidr: -------------------------------------------------------------------------------- 1 | > module Controls 2 | 3 | > import Data.So 4 | > import Data.Vect 5 | 6 | > import Util.VectExtensions1 7 | > import DynamicProgramming.S1201_Context 8 | 9 | 10 | > %default total 11 | 12 | > %access public export 13 | 14 | 15 | > eqeq : Ctrl t x -> Ctrl t x -> Bool 16 | 17 | > eqeqSpec1 : (y : Ctrl t x) -> So (Controls.eqeq y y) 18 | 19 | These allow us to introduce the following abbreviations: 20 | 21 | > isIn : Ctrl t x -> (n : Nat ** Vect n (Ctrl t x)) -> Bool 22 | > isIn {t} {x} = VectExtensions1.isIn (Ctrl t x) Controls.eqeq Controls.eqeqSpec1 23 | 24 | > lemma3 : (y : Ctrl t x) -> 25 | > (p : Ctrl t x -> Bool) -> 26 | > (ys : (n : Nat ** Vect n (Ctrl t x))) -> 27 | > So (p y) -> 28 | > So (y `Controls.isIn` ys) -> 29 | > So (isAnyBy p ys) 30 | > lemma3 {t} {x} = VectExtensions1.lemma3 (Ctrl t x) Controls.eqeq Controls.eqeqSpec1 31 | 32 | > whole : (n : Nat ** Vect n (Ctrl t x)) -> Type 33 | > whole {t} {x} = VectExtensions1.whole (Ctrl t x) Controls.eqeq Controls.eqeqSpec1 34 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/DynamicProgramming/S1302_Reachability.lidr: -------------------------------------------------------------------------------- 1 | > module Reachability 2 | 3 | > import Data.So 4 | 5 | > import Util.VectExtensions1 6 | > import DynamicProgramming.S1301_Context 7 | 8 | 9 | > %default total 10 | 11 | 12 | > reachable : State t -> Bool 13 | 14 | > Reachable : State t -> Type 15 | > Reachable x = So (reachable x) 16 | 17 | > reachableSpec0 : (x : State Z) -> Reachable x 18 | > reachableSpec1 : (x : State t) -> Reachable x -> (y : Ctrl t x) -> 19 | > (x' : State (S t)) -> So (x' `MisIn` (step t x y)) -> Reachable x' 20 | > reachableSpec2 : (x' : State (S t)) -> Reachable x' -> 21 | > (x : State t ** (Reachable x, (y : Ctrl t x ** So (x' `MisIn` (step t x y))))) 22 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/DynamicProgramming/S1302_Viability.lidr: -------------------------------------------------------------------------------- 1 | > module Viability 2 | 3 | > import Data.So 4 | 5 | > import Util.VectExtensions1 6 | > import DynamicProgramming.S1301_Context 7 | 8 | > %default total 9 | 10 | 11 | > viable : (n : Nat) -> State t -> Bool 12 | 13 | > Viable : (n : Nat) -> State t -> Type 14 | > Viable n x = So (viable n x) 15 | 16 | > Mfeasible : (n : Nat) -> (x : State t) -> Ctrl t x -> Bool 17 | > Mfeasible {t} n x y = MareAllTrue (Mmap (viable n) (step t x y)) 18 | 19 | > MFeasible : (n : Nat) -> (x : State t) -> Ctrl t x -> Type 20 | > MFeasible n x y = So (Mfeasible n x y) 21 | 22 | > GoodCtrl : (t : Nat) -> (n : Nat) -> State t -> Type 23 | > GoodCtrl t n x = (y : Ctrl t x ** MFeasible n x y) 24 | 25 | > viableSpec0 : (x : State t) -> Viable Z x 26 | > viableSpec1 : (x : State t) -> Viable (S n) x -> GoodCtrl t n x 27 | > viableSpec2 : (x : State t) -> GoodCtrl t n x -> Viable (S n) x 28 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/DynamicProgramming/S1304_MaxArgmax.lidr: -------------------------------------------------------------------------------- 1 | > module MaxArgmax 2 | 3 | > import Data.So 4 | 5 | > import DynamicProgramming.S1301_Context 6 | > import DynamicProgramming.S1302_Reachability 7 | > import DynamicProgramming.S1302_Viability 8 | > import DynamicProgramming.S1303_OptimalPolicies 9 | 10 | 11 | > max : (n : Nat) -> 12 | > (x : State t) -> 13 | > (r : Reachable x) -> 14 | > (v : Viable (S n) x) -> 15 | > (f : (y : Ctrl t x ** So (Mfeasible n x y))-> Double) -> 16 | > Double 17 | 18 | 19 | > argmax : (n : Nat) -> 20 | > (x : State t) -> 21 | > (r : Reachable x) -> 22 | > (v : Viable (S n) x) -> 23 | > (f : (y : Ctrl t x ** So (Mfeasible n x y))-> Double) -> 24 | > (y : Ctrl t x ** So (Mfeasible n x y)) 25 | 26 | 27 | > maxSpec : (n : Nat) -> 28 | > (x : State t) -> 29 | > (r : Reachable {t} x) -> 30 | > (v : Viable {t} (S n) x) -> 31 | > (f : (y : Ctrl t x ** So (Mfeasible n x y))-> Double) -> 32 | > (yv : (y : Ctrl t x ** So (Mfeasible n x y))) -> 33 | > So (f yv <= max n x r v f) 34 | 35 | 36 | > argmaxSpec : (n : Nat) -> 37 | > (x : State t) -> 38 | > (r : Reachable x) -> 39 | > (v : Viable (S n) x) -> 40 | > (f : (y : Ctrl t x ** So (Mfeasible {t = t} n x y))-> Double) -> 41 | > So (f (argmax n x r v f) == max n x r v f) 42 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/DynamicProgramming/TODO.md: -------------------------------------------------------------------------------- 1 | * Make module names and file names correspond 2 | ** probably by creating three subdirectories instead of the S1101_ prefixes. 3 | 4 | Done: 5 | * Add at least one type-checking example 6 | ** S1206_Example1.lidr 7 | ** See ../Makefile for the command line to compile and run the example 8 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/EffectException.lidr: -------------------------------------------------------------------------------- 1 | > module EffectException 2 | 3 | 4 | > import Effects 5 | > import Effect.Exception 6 | > import Data.So 7 | 8 | > import Nat.Properties 9 | > import BoundedNat.Blt 10 | 11 | 12 | > %default total 13 | 14 | > %access public export 15 | 16 | 17 | > ||| Parses a string for a Nat 18 | > parseNat : String -> { [EXCEPTION String] } Eff Nat 19 | > parseNat str 20 | > = if all (\x => isDigit x) (unpack str) 21 | > then pure (cast {to = Nat} (cast {to = Int} str)) 22 | > else raise "Not a Nat!" 23 | 24 | 25 | > ||| Parses a string for a bounded Nat 26 | > parseBlt : (b : Nat) -> String -> { [EXCEPTION String] } Eff (Blt b) 27 | > parseBlt b str 28 | > = if all (\x => isDigit x) (unpack str) 29 | > then let n = cast {to = Nat} (cast {to = Int} str) in 30 | > case (n < b) of 31 | > True => pure (MkDPair n (believe_me Oh)) 32 | > False => raise "Out of bound!" 33 | > else raise "Not a Nat!" 34 | 35 | 36 | > ||| Parses a string for an Int 37 | > parseInt : String -> { [EXCEPTION String] } Eff Int 38 | > parseInt str 39 | > = if all (\x => isDigit x || x == '-') (unpack str) 40 | > then pure (cast {to = Int} str) 41 | > else raise "Not an Int!" 42 | 43 | 44 | -- Local Variables: 45 | -- idris-packages: ("effects") 46 | -- End: 47 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/EffectStdIO.lidr: -------------------------------------------------------------------------------- 1 | > module EffectStdIO 2 | 3 | > import Effects 4 | > import Effect.StdIO 5 | > import Effect.Exception 6 | > import Data.So 7 | 8 | > import EffectException 9 | > import BoundedNat.Blt 10 | 11 | 12 | > %default total 13 | 14 | > %access public export 15 | 16 | 17 | > ||| 18 | > %assert_total -- termination not required 19 | > getNat : { [STDIO] } Eff Nat 20 | > getNat = 21 | > do putStr (" Nat: " ) 22 | > case the (Either String Nat) (run (parseNat (trim !getStr))) of 23 | > Left err => do putStr (err ++ "\n") 24 | > getNat 25 | > Right n => do putStr "thanks!\n" 26 | > pure n 27 | 28 | 29 | > ||| 30 | > %assert_total -- termination not required 31 | > getBlt : (b : Nat) -> { [STDIO] } Eff (Blt b) 32 | > getBlt b = 33 | > do putStr (" Nat, < " ++ cast {from = Int} (cast b) ++ ": " ) 34 | > case the (Either String (Blt b)) (run (parseBlt b (trim !getStr))) of 35 | > Left err => do putStr (err ++ "\n") 36 | > getBlt b 37 | > Right n => do putStr "thanks!\n" 38 | > pure n 39 | 40 | 41 | -- Local Variables: 42 | -- idris-packages: ("effects") 43 | -- End: 44 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Exists/Ops.lidr: -------------------------------------------------------------------------------- 1 | > module Ops 2 | 3 | 4 | > %default total 5 | 6 | > %access public export 7 | 8 | 9 | > outl : {A : Type} -> {P : A -> Type} -> (a : A ** P a) -> A 10 | > outl = fst 11 | 12 | > outr : {A : Type} -> {P : A -> Type} -> (p : (a : A ** P a)) -> P (outl p) 13 | > outr = snd 14 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/List/Ops.lidr: -------------------------------------------------------------------------------- 1 | > module Ops 2 | 3 | 4 | > rescale : Double -> List (alpha, Double) -> List (alpha, Double) 5 | 6 | -- > rescale t axs = [(a, x * t) | (a, x) <- axs] 7 | 8 | > rescale t axs = map (\ (a,x) => (a,x * t)) axs 9 | 10 | rescale 1 = id 11 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Logic/Ops.lidr: -------------------------------------------------------------------------------- 1 | > module Ops 2 | 3 | Basic propositional connectives at |Type|-level instead of |Bool|. 4 | 5 | Defined already in Prelude.Basics as follows (in comment here): 6 | 7 | Not : (A : Type) -> Type 8 | Not A = A -> Void 9 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Logic/Postulates.lidr: -------------------------------------------------------------------------------- 1 | > module Postulates 2 | 3 | > -- import Logic.Ops 4 | 5 | We should only need to postulate classical properties. 6 | 7 | > doubleNeg : {A : Type} -> Not (Not A) -> A -- cannot postulate??? 8 | > doubleNeg nna = believe_me "Error: evaluated doubleNeg!" 9 | 10 | 11 | 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Logic/Properties.lidr: -------------------------------------------------------------------------------- 1 | > module Properties 2 | 3 | > import Data.So 4 | 5 | > %default total 6 | > %access public export 7 | 8 | 9 | > leibniz : (P : alpha -> Type) -> a1 = a2 -> P a1 -> P a2 10 | > leibniz P Refl p = p 11 | 12 | 13 | Reminder: 14 | 15 | data So : Bool -> Type where 16 | Oh : So True 17 | 18 | > total soElim : (C : (b : Bool) -> So b -> Type) -> 19 | > C True Oh -> 20 | > (b : Bool) -> (s : So b) -> (C b s) 21 | > soElim C coh True Oh = coh 22 | 23 | > soFalseElim : So False -> a 24 | > soFalseElim x = void (soElim C () False x) 25 | > where 26 | > C : (b : Bool) -> So b -> Type 27 | > C True s = () 28 | > C False s = Void 29 | 30 | > soTrue : So b -> b = True 31 | > soTrue {b = False} x = soFalseElim x 32 | > soTrue {b = True} x = Refl 33 | 34 | > soTrueIntro : b = True -> So b 35 | > soTrueIntro {b = False} x = void (trueNotFalse (sym x)) 36 | > soTrueIntro {b = True} x = Oh 37 | 38 | 39 | > soIntro : (b : Bool) -> Dec (So b) 40 | > soIntro False = (No soFalseElim) 41 | > soIntro True = (Yes Oh) 42 | 43 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Makefile: -------------------------------------------------------------------------------- 1 | IDRIS = idris 2 | IDRISFLAGS = +RTS -K32000000 -RTS -p contrib -p effects -V 3 | 4 | all: 5 | find . -name '*.lidr' | xargs -n 1 ${IDRIS} ${IDRISFLAGS} -i .. --check 6 | 7 | example: 8 | ${IDRIS} ${IDRISFLAGS} DynamicProgramming/S1206_CylinderExample1.lidr -o example 9 | 10 | run: example 11 | echo "3\n1" | ./example 12 | 13 | knapsack: 14 | ${IDRIS} ${IDRISFLAGS} DynamicProgramming/S1106_KnapsackExample.lidr -o DynamicProgramming/knapsack.exe 15 | 16 | cylinder1: 17 | ${IDRIS} ${IDRISFLAGS} DynamicProgramming/S1206_CylinderExample1.lidr -o DynamicProgramming/cylinder1.exe 18 | 19 | cylinder4: 20 | ${IDRIS} ${IDRISFLAGS} DynamicProgramming/S1206_CylinderExample4.lidr -o DynamicProgramming/cylinder4.exe 21 | 22 | clean: 23 | -rm example 24 | -find . -name '*.ibc' -delete 25 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Nat/Operations.lidr: -------------------------------------------------------------------------------- 1 | > module Operations 2 | 3 | 4 | > %default total 5 | 6 | > %access public export 7 | 8 | > %hide (-) 9 | 10 | 11 | Infix minus: 12 | 13 | > (-) : Nat -> Nat -> Nat 14 | > (-) = minus 15 | 16 | 17 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Prob/testSimpleProb.lidr: -------------------------------------------------------------------------------- 1 | > module Main 2 | 3 | > import Prob.SimpleProb 4 | 5 | > castN2D : Nat -> Double 6 | > castN2D = cast {to = Double} {from = Int} . cast 7 | 8 | > n1 : Nat 9 | > n1 = 1 10 | 11 | > n2 : Nat 12 | > n2 = 40 13 | 14 | -- 15 | 16 | > d1 : Double 17 | > d1 = 1.0 / (castN2D n1) 18 | 19 | > xp1 : List (Double, Double) 20 | > xp1 = [(castN2D i, d1) | i <- [1..n1]] 21 | 22 | > sp1 : SimpleProb Double 23 | > sp1 = SP xp1 24 | 25 | > ssp1 : List Double 26 | > ssp1 = supp sp1 27 | 28 | -- 29 | 30 | > d2 : Double 31 | > d2 = 1.0 / (castN2D n2) 32 | 33 | > xp2 : List (Double, Double) 34 | > xp2 = [(castN2D i, d2) | i <- [1..n2]] 35 | 36 | > sp2 : SimpleProb Double 37 | > sp2 = SP xp2 38 | 39 | > ssp2 : List Double 40 | > ssp2 = supp sp2 41 | 42 | -- 43 | 44 | > sp : SimpleProb Double 45 | > sp = convComb eps sp1 sp2 where 46 | > eps = 0.1 47 | 48 | -- 49 | 50 | > main : IO () 51 | > main = do 52 | > putStrLn ("supp sp1 = " ++ (show ssp1) ) 53 | > putStrLn ("supp sp2 = " ++ (show ssp2) ) 54 | > putStrLn ("supp sp = " ++ (show (supp sp)) ) 55 | > putStrLn ("eValue sp1 = " ++ (show (eValue sp1)) ) 56 | > putStrLn ("eValue sp2 = " ++ (show (eValue sp2)) ) 57 | > putStrLn ("eValue sp = " ++ (show (eValue sp)) ) 58 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Rel/DecEq.lidr: -------------------------------------------------------------------------------- 1 | > module DecEq 2 | 3 | > -- import Logic.Ops 4 | 5 | 6 | > interface DecEq alpha where 7 | > dec_eq : (a : alpha) -> 8 | > (a' : alpha) -> 9 | > Either (a = a') (Not (a = a')) 10 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Rel/EqEq.lidr: -------------------------------------------------------------------------------- 1 | > module EqEq 2 | 3 | 4 | > interface Eq alpha => EqEq alpha where 5 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Rel/Postulates.lidr: -------------------------------------------------------------------------------- 1 | > module Postulates 2 | 3 | 4 | > import Rel.Syntax 5 | 6 | 7 | 8 | 9 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Rel/Properties.lidr: -------------------------------------------------------------------------------- 1 | > module Properties 2 | 3 | 4 | > import Rel.Syntax 5 | > import Rel.Postulates 6 | 7 | > eqTrans : {A : Type} -> {a1 : A} -> {a2 : A} -> {a3 : A} -> 8 | > a1 = a2 -> a2 = a3 -> a1 = a3 9 | > eqTrans {a1} {a2} {a3} p12 p23 = replace -- {P = \ a => a1 = a} 10 | > p23 p12 11 | 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Rel/ReflDecEq.lidr: -------------------------------------------------------------------------------- 1 | > module ReflDecEq 2 | 3 | > -- import Logic.Ops 4 | > import Rel.DecEq 5 | 6 | 7 | > interface DecEq.DecEq alpha => ReflDecEq alpha where 8 | > reflexive_dec_eq : (a : alpha) -> 9 | > dec_eq a a = Left {a = (a = a)} {b = (Not (a = a))} Refl 10 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Rel/ReflEqEq.lidr: -------------------------------------------------------------------------------- 1 | > module ReflEqEq 2 | 3 | > import Data.So 4 | 5 | > import Logic.Properties 6 | > import Rel.EqEq 7 | 8 | 9 | > interface EqEq alpha => ReflEqEq alpha where 10 | > reflexive_eqeq : (a : alpha) -> So (a == a) 11 | > Reflexive_eqeq : (a : alpha) -> (a == a) = True 12 | > Reflexive_eqeq a = soElim C Refl (a == a) (reflexive_eqeq a) where 13 | > C : (b : Bool) -> So b -> Type 14 | > C b s = b = True 15 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Rel/Syntax.lidr: -------------------------------------------------------------------------------- 1 | > module Syntax 2 | 3 | > import Data.So 4 | 5 | 6 | > %default total 7 | 8 | 9 | > syntax reflexive [alpha] [r] = (a : alpha) -> So (r a a) 10 | 11 | > syntax symmetric [alpha] [r] = {a1 : alpha} -> 12 | > {a2 : alpha} -> 13 | > So (r a1 a2) -> 14 | > So (r a2 a1) 15 | 16 | > syntax transitive [alpha] [r] = {a1 : alpha} -> 17 | > {a2 : alpha} -> 18 | > {a3 : alpha} -> 19 | > So (r a1 a2) -> 20 | > So (r a2 a3) -> 21 | > So (r a1 a3) 22 | 23 | > syntax sub [alpha] [r1] [r2] = {a1 : alpha} -> 24 | > {a2 : alpha} -> 25 | > So (r1 a1 a2) -> 26 | > So (r2 a1 a2) 27 | 28 | > syntax monotone [alpha] [op2] [r] = {a1 : alpha} -> 29 | > {a2 : alpha} -> 30 | > (a3 : alpha) -> 31 | > So (r a1 a2) -> 32 | > So (r (op2 a3 a1) (op2 a3 a2)) 33 | 34 | > syntax monotone' [alpha] [op2] [r] = {a1 : alpha} -> 35 | > {a2 : alpha} -> 36 | > (a3 : alpha) -> 37 | > So (r (op2 a3 a1) (op2 a3 a2)) -> 38 | > So (r a1 a2) 39 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Set/SetIsType.lidr: -------------------------------------------------------------------------------- 1 | > module SetIsType 2 | 3 | > Set : Type 4 | > Set = Type 5 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Util/Opt.lidr: -------------------------------------------------------------------------------- 1 | > module Opt 2 | 3 | > import Data.Vect 4 | > import Data.So 5 | 6 | > import Logic.Properties 7 | 8 | > %default total 9 | 10 | > %access public export 11 | 12 | 13 | > max2' : (alpha, Double) -> 14 | > (alpha, Double) -> 15 | > (alpha, Double) 16 | > max2' a b = if (snd a < snd b) then b else a 17 | 18 | > max3' : (alpha, Double) -> 19 | > (alpha, Double) -> 20 | > (alpha, Double) -> 21 | > (alpha, Double) 22 | > max3' a b c = max2' a (max2' b c) 23 | 24 | > maxP : Vect (S n) (alpha, Double) -> (alpha, Double) 25 | > maxP (af :: afs) = foldr max2' af afs 26 | 27 | > maxP' : (Vect n (alpha, Double), So (Z < n)) -> (alpha, Double) 28 | > maxP' {n = Z} (Nil, ZltZ) = soFalseElim ZltZ 29 | > maxP' {n = S n} ((af :: afs), _) = foldr max2' af afs 30 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Util/Util.lidr: -------------------------------------------------------------------------------- 1 | > module Util 2 | 3 | > %default total 4 | > %access public export 5 | 6 | 7 | > pair : (a -> b, a -> c) -> a -> (b, c) 8 | > pair (f, g) x = (f x, g x) 9 | 10 | -------------------------------------------------------------------------------- /manuscripts/2014.LMCS/code/Vect/Ops.lidr: -------------------------------------------------------------------------------- 1 | > module Ops 2 | 3 | > import Data.Vect 4 | > import Data.So 5 | > import Data.Fin 6 | 7 | > import BoundedNat.Blt 8 | > import Nat.Postulates 9 | > import Nat.Properties 10 | 11 | 12 | > %default total 13 | 14 | > %access public export 15 | 16 | 17 | > nubbedBy : (alpha -> alpha -> Bool) -> Vect n alpha -> Bool 18 | > nubbedBy {n} p v = n == (fst (nubBy p v)) 19 | 20 | > idx : Vect n alpha -> Blt n -> alpha 21 | > idx {n = Z} Nil b = void (ltZ_bot (snd b)) 22 | > idx {n = S m} (a :: as) (Z ** _) = a 23 | > idx {n = S m} (a :: as) (S k ** q) = idx {n = m} as (k ** lemma5 q) 24 | 25 | > idx1 : Vect n alpha -> Blt n -> alpha 26 | > idx1 = idx 27 | 28 | > idx2 : Vect m (Vect n alpha) -> 29 | > (i : Blt m) -> 30 | > (j : Blt n) -> 31 | > alpha 32 | > idx2 xss i j = idx1 (idx1 xss i) j 33 | 34 | 35 | > xdi : (p : alpha -> alpha -> Bool) -> 36 | > (a : alpha) -> 37 | > (as : Vect n alpha) -> 38 | > So (elemBy p a as) -> 39 | > Blt n 40 | > xdi p a as q = (fromMaybe Z m ** believe_me Oh) where 41 | > m : Maybe Nat 42 | > m = map finToNat (findIndex (p a) as) 43 | -------------------------------------------------------------------------------- /manuscripts/2015.JFP/code/README.md: -------------------------------------------------------------------------------- 1 | TODOs: 2 | * Generalise the reward from Double to some preorder 3 | * Package all the assumptions (global metavariables) as a record (or a type class) 4 | * X, finX, decEqX, -- State space 5 | * Y, finY, -- Control space 6 | * step, -- (monadic) step function 7 | * reward, 8 | * max, argmax, maxSpec, argmaxSpec, 9 | * MeasLib.measMon, MeasLib.meas, 10 | * MonadLib.M, MonadLib.fmap, MonadLib.bind,MonadLib.ret, 11 | * ContainerMonadLib.Elem, ContainerMonadLib.tagElem, 12 | * decAll, decElem 13 | -------------------------------------------------------------------------------- /manuscripts/2015.JFP/code/deterministic.lidr: -------------------------------------------------------------------------------- 1 | > module Deterministic 2 | 3 | 4 | > %default total 5 | 6 | 7 | > Prop : Type 8 | > Prop = Type 9 | 10 | 11 | > X : (t : Nat) -> Type 12 | 13 | > Y : (t : Nat) -> (x : X t) -> Type 14 | 15 | > step : (t : Nat) -> (x : X t) -> (y : Y t x) -> X (S t) 16 | 17 | > reward : (t : Nat) -> (x : X t) -> (y : Y t x) -> (x' : X (S t)) -> Double 18 | 19 | > Pred : X t -> X (S t) -> Type 20 | > Pred {t} x x' = Exists (\ y => x' = step t x y) 21 | 22 | > Viable : (n : Nat) -> X t -> Type 23 | > Viable {t} Z _ = () 24 | > Viable {t} (S m) x = Exists (\ y => Viable m (step t x y)) 25 | 26 | > Reachable : X t' -> Prop 27 | > Reachable {t' = Z} _ = () 28 | > Reachable {t' = S t} x' = Exists (\ x => (Reachable x, x `Pred` x')) 29 | 30 | > Policy' : (t : Nat) -> (n : Nat) -> Type 31 | > Policy' t Z = () 32 | > Policy' t (S m) = (x : X t) -> Viable (S m) x -> (y : Y t x ** Viable m (step t x y)) 33 | 34 | > Policy : (t : Nat) -> (n : Nat) -> Type 35 | > Policy t Z = () 36 | > Policy t (S m) = (x : X t) -> Reachable x -> Viable (S m) x -> 37 | > (y : Y t x ** Viable m (step t x y)) 38 | 39 | > data PolicySeq : (t : Nat) -> (n : Nat) -> Type where 40 | > Nil : PolicySeq t Z 41 | > (::) : Policy t (S n) -> PolicySeq (S t) n -> PolicySeq t (S n) 42 | -------------------------------------------------------------------------------- /manuscripts/2015.JFP/code/non-deterministic.lidr: -------------------------------------------------------------------------------- 1 | > module NonDeterministic 2 | 3 | > %default total 4 | 5 | 6 | > X : (t : Nat) -> Type 7 | 8 | > Y : (t : Nat) -> (x : X t) -> Type 9 | 10 | > step : (t : Nat) -> (x : X t) -> (y : Y t x) -> List (X (S t)) 11 | 12 | > reward : (t : Nat) -> (x : X t) -> (y : Y t x) -> (x' : X (S t)) -> Double 13 | 14 | > fmap : {A, B : Type} -> (A -> B) -> List A -> List B 15 | 16 | > rewards : (t : Nat) -> (x : X t) -> (y : Y t x) -> List Double 17 | > rewards t x y = fmap (reward t x y) (step t x y) 18 | 19 | > reduce : {A : Type} -> List (List A) -> List A 20 | > reduce = concat 21 | 22 | > certain : {A : Type} -> A -> List A 23 | > certain a = [a] 24 | -------------------------------------------------------------------------------- /manuscripts/2015.JFP/code/preliminaries.lidr: -------------------------------------------------------------------------------- 1 | > namespace Nat 2 | > %hide Nat 3 | > %hide Z 4 | > %hide S 5 | > 6 | > data Nat : Type where 7 | > Z : Nat 8 | > S : Nat -> Nat 9 | > 10 | > data Vect : Nat -> Type -> Type where 11 | > Nil : Vect Z a 12 | > Cons : (x : a) -> (xs : Vect n a) -> Vect (S n) a 13 | > 14 | > head : {n : Nat} -> {A : Type} -> Vect (S n) A -> A 15 | > head (Cons x xs) = x 16 | > 17 | > postulate A : Type 18 | > postulate Sorted : Vect n A -> Type 19 | > postulate sort : Vect n A -> Vect n A 20 | > 21 | > SortSpec : Type -- a specificatation of |sort| 22 | > SortSpec = (n : Nat) -> (xs : Vect n A) -> Sorted (sort xs) 23 | > 24 | > sortLemma : SortSpec 25 | > sortLemma = ?hole {- a proof that |sort| satisfies the specification -} 26 | > 27 | > namespace Existential 28 | > %hide Prelude.Pairs.Exists 29 | > using (A : Type, P : A -> Type) 30 | > data Exists : {A : Type} -> (A -> Type) -> Type where 31 | > Evidence : (wit : A) -> (pro : P wit) -> Exists P 32 | > 33 | > getWitness : Exists {A} P -> A 34 | > getWitness (Evidence wit pro) = wit 35 | > 36 | > getProof : (evi : Exists {A} P) -> P (getWitness evi) 37 | > getProof (Evidence wit pro) = pro 38 | > 39 | > data Sigma : (A : Type) -> (A -> Type) -> Type where 40 | > MkSigma : {A : Type} -> {B : A -> Type} -> 41 | > (a : A) -> (b : B a) -> Sigma A B 42 | -------------------------------------------------------------------------------- /manuscripts/2015.JFP/code/stochastic.lidr: -------------------------------------------------------------------------------- 1 | > module Stochastic 2 | 3 | > import Data.So 4 | > import Data.Fin 5 | > import Data.Vect 6 | 7 | > %default total 8 | 9 | 10 | > data Prob : Type -> Type where 11 | > MkProb : {A : Type} -> 12 | > {n : Nat} -> 13 | > (as : Vect n A) -> 14 | > (ps : Vect n Double) -> 15 | > ((i : Fin n) -> So (index i ps >= 0.0)) -> 16 | > sum ps = 1.0 -> 17 | > Prob A 18 | 19 | > X : (t : Nat) -> Type 20 | 21 | > Y : (t : Nat) -> (x : X t) -> Type 22 | 23 | > step : (t : Nat) -> (x : X t) -> (y : Y t x) -> Prob (X (S t)) 24 | 25 | > reward : (t : Nat) -> (x : X t) -> (y : Y t x) -> (x' : X (S t)) -> Double 26 | 27 | > fmap : {A, B : Type} -> (A -> B) -> Prob A -> Prob B 28 | > fmap f (MkProb as ps p q) = MkProb (map f as) ps p q 29 | 30 | > rewards : (t : Nat) -> (x : X t) -> (y : Y t x) -> Prob Double 31 | > rewards t x y = fmap (reward t x y) (step t x y) 32 | 33 | > oneGTzero : So (1.0 >= 0.0) 34 | > oneGTzero = Oh 35 | 36 | > allPos : (i : Fin 1) -> So (index i [1.0] >= 0.0) 37 | > allPos FZ = oneGTzero 38 | > allPos (FS q) = FinZElim q 39 | 40 | > certain : {A : Type} -> A -> Prob A 41 | > certain a = MkProb [a] [1.0] allPos Refl 42 | -------------------------------------------------------------------------------- /old/stochastic.lidr: -------------------------------------------------------------------------------- 1 | > module Stochastic 2 | 3 | 4 | > import Data.Vect 5 | 6 | 7 | > %default total 8 | 9 | 10 | > data Prob : Type -> Type where 11 | > MkProb : {A : Type} -> (as : Vect n A) -> (ps : Vect n Float) -> sum ps = 1.0 -> Prob A 12 | 13 | > X : (t : Nat) -> Type 14 | 15 | > Y : (t : Nat) -> (x : X t) -> Type 16 | 17 | > step : (t : Nat) -> (x : X t) -> (y : Y t x) -> Prob (X (S t)) 18 | 19 | > reward : (t : Nat) -> (x : X t) -> (y : Y t x) -> (x' : X (S t)) -> Float 20 | 21 | > fmap : {A, B : Type} -> (A -> B) -> Prob A -> Prob B 22 | > fmap f (MkProb as ps prf) = MkProb (map f as) ps prf 23 | 24 | > rewards : (t : Nat) -> (x : X t) -> (y : Y t x) -> Prob Float 25 | > rewards t x y = fmap (reward t x y) (step t x y) 26 | 27 | -------------------------------------------------------------------------------- /prototypes/PreTab.lidr: -------------------------------------------------------------------------------- 1 | A sketch for one way of getting rid of exponential blow-up in the 2 | cardinality of RVX. 3 | 4 | This may take us most of the way (after adding indices to X etc.) 5 | 6 | Then we can explore erasure to get rid of proofs at runtime. 7 | 8 | > module PreTab 9 | > import Data.Fin 10 | > import Data.Vect 11 | > import Prop 12 | > import Finite 13 | > import FiniteOperations 14 | > import FiniteProperties 15 | > import VectOperations 16 | > import VectProperties 17 | > import Decidable 18 | > postulate X : Type 19 | > postulate fX : Finite X 20 | > postulate RV : X -> Prop 21 | > postulate decRV : Dec1 RV 22 | > n : Nat 23 | > n = getWitness fX 24 | > rX : Vect n X 25 | > rX = toVect fX 26 | > mfrX : (m : Nat ** Vect m X) 27 | > mfrX = filter decRV rX 28 | > m : Nat 29 | > m = getWitness mfrX 30 | > frX : Vect m X 31 | > frX = getProof mfrX 32 | > postulate x : X 33 | > postulate rv : RV x 34 | > p : Elem x rX 35 | > p = toVectComplete fX x 36 | > k : Fin m 37 | > k = lookup x frX (filterLemma decRV x rX p rv) 38 | -------------------------------------------------------------------------------- /prototypes/pretab.ipkg: -------------------------------------------------------------------------------- 1 | package pretab 2 | 3 | opts = "-i .." 4 | 5 | modules = PreTab 6 | -------------------------------------------------------------------------------- /talks/2015.06.rd4_seminar/Makefile: -------------------------------------------------------------------------------- 1 | slides: slides.tex 2 | pdflatex slides.tex 3 | # dvips -t landscape slides.dvi -o slides.ps 4 | # ps2pdf slides.ps slides.pdf 5 | 6 | slides.tex: slides.lhs slides.fmt 7 | lhs2TeX --poly slides.lhs > slides.tex 8 | - pdflatex slides.tex 9 | asy *.asy 10 | 11 | clean: 12 | - rm *.pre *.vrb *.asy slides.tex slides-*.pdf slides.ps slides.dvi slides.aux slides.log slides.toc slides.ptb slides.nav slides.out slides.snm 13 | -------------------------------------------------------------------------------- /talks/2015.06.rd4_seminar/black.lhs: -------------------------------------------------------------------------------- 1 | \renewcommand{\hscodestyle}{% 2 | \setlength\leftskip{1em}% 3 | \small 4 | \color{black} 5 | } 6 | -------------------------------------------------------------------------------- /talks/2015.06.rd4_seminar/code/Decidable.lidr: -------------------------------------------------------------------------------- 1 | > module Decidable 2 | 3 | 4 | > %default total 5 | 6 | 7 | > Dec0 : Type -> Type 8 | > Dec0 = Dec 9 | 10 | > Dec1 : {A : Type} -> (P : A -> Type) -> Type 11 | > Dec1 {A} P = (a : A) -> Dec0 (P a) 12 | 13 | > DecEq0 : Type -> Type 14 | > DecEq0 A = (a1 : A) -> (a2 : A) -> Dec (a1 = a2) 15 | 16 | > DecEq1 : {A : Type} -> (P : A -> Type) -> Type 17 | > DecEq1 {A} P = (a : A) -> DecEq0 (P a) 18 | -------------------------------------------------------------------------------- /talks/2015.06.rd4_seminar/code/Finite.lidr: -------------------------------------------------------------------------------- 1 | > module Finite 2 | > import Prelude.Maybe 3 | > import Data.Fin 4 | > import Control.Isomorphism 5 | > -- import EmbProj 6 | > 7 | > %default total 8 | 9 | 10 | > ||| Notion of finiteness for types 11 | > Finite : Type -> Type 12 | > Finite A = Exists (\ n => Iso A (Fin n)) 13 | 14 | > Finite0 : Type -> Type 15 | > Finite0 = Finite 16 | 17 | > Finite1 : {A : Type} -> (P : A -> Type) -> Type 18 | > Finite1 {A} P = (a : A) -> Finite0 (P a) 19 | 20 | > {- 21 | 22 | This definition requires an exact cardinality |n| which may be 23 | difficult to compute. But it is enough to know a finite bound, so an 24 | alternative definition which may be more convenient is the following: 25 | 26 | > FiniteSub : Type -> Type 27 | > FiniteSub A = Exists (\ n => EmbProj A (Fin n)) 28 | 29 | ---------------- 30 | 31 | > FiniteN : Nat -> Type -> Type 32 | > FiniteN n A = Iso A (Fin n) 33 | 34 | > ---} 35 | -------------------------------------------------------------------------------- /talks/2015.06.rd4_seminar/code/Nat.lidr: -------------------------------------------------------------------------------- 1 | > module Nat 2 | 3 | 4 | > %default total 5 | 6 | > %hide Nat 7 | > %hide Z 8 | > %hide S 9 | 10 | > namespace lala 11 | 12 | > data Nat : Type where 13 | > Z : Nat 14 | > S : Nat -> Nat 15 | -------------------------------------------------------------------------------- /talks/2015.06.rd4_seminar/code/Preorder.lidr: -------------------------------------------------------------------------------- 1 | > module Preorder 2 | 3 | 4 | > %default total 5 | 6 | 7 | > ||| Preorder 8 | > data Preorder : Type -> Type where 9 | > MkPreorder : {A : Type} -> 10 | > (R : A -> A -> Type) -> 11 | > (reflexive : (x : A) -> R x x) -> 12 | > (transitive : (x : A) -> (y : A) -> (z : A) -> R x y -> R y z -> R x z) -> 13 | > Preorder A 14 | 15 | 16 | > {- 17 | 18 | > ||| Preorder on t 19 | > class Preorder t where 20 | > total C : t -> t -> Type 21 | > total reflexive : (x : t) -> C x x 22 | > total transitive : (x : t) -> (y : t) -> (z : t) -> C x y -> C y z -> C x z 23 | 24 | 25 | > ||| Total preorder on t 26 | > class (Preorder t) => TotalPreorder t where 27 | > total totalPre : (x : t) -> (y : t) -> Either (C x y) (C y x) 28 | 29 | > -} 30 | 31 | 32 | > {- 33 | 34 | > ||| Preorder on t 35 | > class Preorder (t : Type) (po : t -> t -> Type) where 36 | > total reflexive : (x : t) -> po x x 37 | > total transitive : (x : t) -> (y : t) -> (z : t) -> po x y -> po y z -> po x z 38 | 39 | > ||| Preorders on |t1| induce preorders on |(t1, t2)| 40 | > instance Preorder t1 po => Preorder (t1, t2) (\ x => \ y => po (fst x) (fst y)) where 41 | > reflexive x = reflexive (fst x) 42 | > transitive x y z xy yz = transitive (fst x) (fst y) (fst z) xy yz 43 | 44 | > -} 45 | 46 | 47 | > {- 48 | 49 | > class (Preorder t to) => Preordered t (to : t -> t -> Type) | t where 50 | > total preorder : (a : t) -> (b : t) -> Either (to a b) (to b a) 51 | 52 | > -} 53 | -------------------------------------------------------------------------------- /talks/2015.06.rd4_seminar/code/Prob.lidr: -------------------------------------------------------------------------------- 1 | > module Prob 2 | 3 | > import Data.Vect 4 | 5 | 6 | > %default total 7 | 8 | 9 | > data Prob : Type -> Type where 10 | > mkProb : (as : Vect n a) -> (ps : Vect n Float) -> sum ps = 1.0 -> Prob a 11 | -------------------------------------------------------------------------------- /talks/2015.06.rd4_seminar/code/TotalPreorder.lidr: -------------------------------------------------------------------------------- 1 | > module TotalPreorder 2 | 3 | > import Preorder 4 | 5 | > %default total 6 | 7 | 8 | > ||| TotalPreorder 9 | > data TotalPreorder : Type -> Type where 10 | > MkTotalPreorder : {A : Type} -> 11 | > (R : A -> A -> Type) -> 12 | > (reflexive : (x : A) -> R x x) -> 13 | > (transitive : (x : A) -> (y : A) -> (z : A) -> R x y -> R y z -> R x z) -> 14 | > (totalPre : (x : A) -> (y : A) -> Either (R x y) (R y x)) -> 15 | > TotalPreorder A 16 | -------------------------------------------------------------------------------- /talks/2015.06.rd4_seminar/gray.lhs: -------------------------------------------------------------------------------- 1 | \renewcommand{\hscodestyle}{% 2 | \setlength\leftskip{1em}% 3 | \small 4 | \color{gray} 5 | } 6 | -------------------------------------------------------------------------------- /talks/2015.06.rd4_seminar/macros.TeX: -------------------------------------------------------------------------------- 1 | \newtheorem{thm}{Theorem} 2 | \newtheorem{prop}{Proposition} 3 | \newtheorem{dfn}{Definition} 4 | \newtheorem{exm}{Example} 5 | \newtheorem{cor}{Corollary} 6 | 7 | \newcommand{\To}{\longrightarrow} 8 | \newcommand{\Nat}{\mathbb{N}} 9 | \newcommand{\Real}{\mathbb{R}} 10 | \newcommand{\id}{\mathrm{id}} 11 | \newcommand{\Hom}{\mathrm{Hom}} 12 | \newcommand{\unit}{\mathrm{unit}} 13 | \newcommand{\cat}[1]{\mathbf{#1}} 14 | 15 | \def\commentbegin{\quad\{\ } 16 | \def\commentend{\}} 17 | 18 | \providecommand{\TODO}[1]{\textbf{TODO}\footnote{\textbf{#1}}} 19 | -------------------------------------------------------------------------------- /talks/2015.06.rd4_seminar/red.lhs: -------------------------------------------------------------------------------- 1 | \renewcommand{\hscodestyle}{% 2 | \setlength\leftskip{1em}% 3 | \small 4 | \color{red} 5 | } 6 | -------------------------------------------------------------------------------- /talks/2015.06.rd4_seminar/schellnhuber.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nicolabotta/SeqDecProbs/1320e64dfd138f47aefac8b418231b05bd779f34/talks/2015.06.rd4_seminar/schellnhuber.pdf -------------------------------------------------------------------------------- /talks/2015.06.rd4_seminar/slides.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nicolabotta/SeqDecProbs/1320e64dfd138f47aefac8b418231b05bd779f34/talks/2015.06.rd4_seminar/slides.pdf -------------------------------------------------------------------------------- /talks/2016-11_Oxford/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | -------------------------------------------------------------------------------- /talks/2016-11_Oxford/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Patrik Jansson 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Patrik Jansson nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /talks/2016-11_Oxford/SeqDecProbs.cabal: -------------------------------------------------------------------------------- 1 | -- Initial SeqDecProbs.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: SeqDecProbs 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Patrik Jansson 11 | maintainer: patrik.ja@gmail.com 12 | -- copyright: 13 | -- category: 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | library 19 | exposed-modules: Example 20 | -- other-modules: 21 | -- other-extensions: 22 | build-depends: base >=4.9 && <4.10 23 | -- hs-source-dirs: 24 | default-language: Haskell2010 -------------------------------------------------------------------------------- /talks/2016-11_Oxford/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | --------------------------------------------------------------------------------