diff --git a/.gitignore b/.gitignore index 94f90f9f14..9d9c273672 100644 --- a/.gitignore +++ b/.gitignore @@ -77,6 +77,10 @@ compiler/benchmarks/*.dat compiler/benchmarks/*.eps #sexp files generated by Icing -icing/examples/output/*/*.sexp.cml -icing/examples/*_data_prog.txt +floatingPoint/icing/examples/output/*/*.sexp.cml +floatingPoint/icing/examples/*_data_prog.txt .DS_Store + +#Sollya build files for floating-point tools +floatingPoint/tools/dandelion/sollya-8.0/* + diff --git a/candle/prover/candle_prover_evaluateScript.sml b/candle/prover/candle_prover_evaluateScript.sml index b92b47cf54..a11d660d45 100644 --- a/candle/prover/candle_prover_evaluateScript.sml +++ b/candle/prover/candle_prover_evaluateScript.sml @@ -649,6 +649,11 @@ Proof \\ first_assum (irule_at Any) \\ simp [v_ok_def]) \\ Cases_on ‘op = RealFromFP’ \\ gs[] + >- ( + rw[do_app_cases] \\ gs [SF SFY_ss] + \\ first_assum (irule_at Any) + \\ simp [v_ok_def]) + \\ Cases_on ‘op = RealFromIntProd’ \\ gs[] >- ( rw[do_app_cases] \\ gs [SF SFY_ss] \\ first_assum (irule_at Any) diff --git a/candle/prover/permsScript.sml b/candle/prover/permsScript.sml index 5bee8e1b0a..b1c9e22405 100644 --- a/candle/prover/permsScript.sml +++ b/candle/prover/permsScript.sml @@ -578,6 +578,10 @@ Proof rw [do_app_cases] \\ gs[] \\ rw [perms_ok_def]) \\ Cases_on ‘op = RealFromFP’ \\ gs[] + >- ( + rw [do_app_cases] \\ gs[] + \\ rw [perms_ok_def]) + \\ Cases_on ‘op = RealFromIntProd’ \\ gs[] >- ( rw [do_app_cases] \\ gs[] \\ rw [perms_ok_def]) diff --git a/compiler/inference/inferScript.sml b/compiler/inference/inferScript.sml index a66eb5a70c..1fff8fb99b 100644 --- a/compiler/inference/inferScript.sml +++ b/compiler/inference/inferScript.sml @@ -378,6 +378,7 @@ val op_to_string_def = Define ` (op_to_string (Real_uop _) = (implode "Real_uop", 1)) ∧ (op_to_string (Real_cmp _) = (implode "Real_cmp", 2)) ∧ (op_to_string (RealFromFP) = (implode "RealFromFP", 1)) ∧ +(op_to_string (RealFromIntProd) = (implode "RealFromIntProd", 1)) ∧ (op_to_string (Shift _ _ _) = (implode "Shift", 1)) ∧ (op_to_string Equality = (implode "Equality", 2)) ∧ (op_to_string Opapp = (implode "Opapp", 2)) ∧ @@ -556,6 +557,7 @@ constrain_op l op ts = | (Real_bop _, _) => failwith l (implode "Reals do not have a type") | (Real_cmp _, _) => failwith l (implode "Reals do not have a type") | (RealFromFP, _) => failwith l (implode "Reals do not have a type") + | (RealFromIntProd, _) => failwith l (implode "Reals do not have a type") | (AallocFixed, _) => failwith l (implode "Unsafe ops do not have a type") (* not actually unsafe *) | (Eval, _) => failwith l (implode "Unsafe ops do not have a type") | (Env_id, _) => failwith l (implode "Unsafe ops do not have a type") diff --git a/compiler/parsing/fromSexpScript.sml b/compiler/parsing/fromSexpScript.sml index 60c3962fb6..23a31f1905 100644 --- a/compiler/parsing/fromSexpScript.sml +++ b/compiler/parsing/fromSexpScript.sml @@ -688,6 +688,7 @@ val sexpop_def = Define` if s = "RealbopRealMul" then SOME (Real_bop realOps$Real_Mul) else if s = "RealbopRealDiv" then SOME (Real_bop realOps$Real_Div) else if s = "RealFromFP" then SOME (RealFromFP) else + if s = "RealFromIntProd" then SOME (RealFromIntProd) else if s = "Opapp" then SOME Opapp else if s = "Opassign" then SOME Opassign else if s = "Opref" then SOME Opref else @@ -1335,6 +1336,7 @@ val opsexp_def = Define` (opsexp (Real_bop realOps$Real_Mul) = SX_SYM "RealbopRealMul") ∧ (opsexp (Real_bop realOps$Real_Div) = SX_SYM "RealbopRealDiv") ∧ (opsexp (RealFromFP) = SX_SYM "RealFromFP") ∧ + (opsexp (RealFromIntProd) = SX_SYM "RealFromIntProd") ∧ (opsexp Opapp = SX_SYM "Opapp") ∧ (opsexp Opassign = SX_SYM "Opassign") ∧ (opsexp Opref = SX_SYM "Opref") ∧ diff --git a/compiler/repl/evaluate_initScript.sml b/compiler/repl/evaluate_initScript.sml index 36b7fddda7..4e930deaee 100644 --- a/compiler/repl/evaluate_initScript.sml +++ b/compiler/repl/evaluate_initScript.sml @@ -675,6 +675,11 @@ Proof \\ ‘s with <| refs := s.refs; ffi := s.ffi |> = s’ suffices_by gs[] \\ gs[state_component_equality]) \\ Cases_on ‘op = RealFromFP’ \\ gs[] + >- ( + gvs[do_app_cases, v_ok_thm] + \\ ‘s with <| refs := s.refs; ffi := s.ffi |> = s’ suffices_by gs[] + \\ gs[state_component_equality]) + \\ Cases_on ‘op = RealFromIntProd’ \\ gs[] >- ( gvs[do_app_cases, v_ok_thm] \\ ‘s with <| refs := s.refs; ffi := s.ffi |> = s’ suffices_by gs[] diff --git a/compiler/repl/evaluate_skipScript.sml b/compiler/repl/evaluate_skipScript.sml index b264fb198a..1348f858aa 100644 --- a/compiler/repl/evaluate_skipScript.sml +++ b/compiler/repl/evaluate_skipScript.sml @@ -1790,6 +1790,13 @@ Proof \\ rpt (irule_at Any SUBMAP_REFL) \\ gs [] \\ first_assum (irule_at Any) \\ gs []) \\ Cases_on ‘op = RealFromFP’ \\ gs[] + >- ( + Cases_on ‘res’ \\ gvs [do_app_def, v_rel_def, OPTREL_def, + CaseEqs ["list", "v", "option", "prod", "lit", + "store_v", "v"]] + \\ rpt (irule_at Any SUBMAP_REFL) \\ gs [] + \\ first_assum (irule_at Any) \\ gs []) + \\ Cases_on ‘op = RealFromIntProd’ \\ gs[] >- ( Cases_on ‘res’ \\ gvs [do_app_def, v_rel_def, OPTREL_def, CaseEqs ["list", "v", "option", "prod", "lit", diff --git a/developers/build-sequence b/developers/build-sequence index be0ab49a3e..b98c8f9858 100644 --- a/developers/build-sequence +++ b/developers/build-sequence @@ -4,6 +4,14 @@ developers developers/bin +# Floating-Point optimizer & codegen +floatingPoint/tools/dandelion +floatingPoint/icing/ +floatingPoint/icing/examples + +# Floating-Point codegen +floatingPoint/libmGen/ + # build many things in parallel at the start compiler/proofs compiler/bootstrap/translation @@ -127,11 +135,6 @@ compiler/parsing/tests compiler/inference/tests compiler/printing/test -# Floating-Point optimizer -icing/flover -icing/ -icing/examples - # compiler translation compiler/repl diff --git a/floatingPoint/README.md b/floatingPoint/README.md new file mode 100644 index 0000000000..859907b9d9 --- /dev/null +++ b/floatingPoint/README.md @@ -0,0 +1,5 @@ +# Floating-point related tooling for CakeML + +This directory contains tools for implementation of elementary functions (`libmGen`), +and to optimize floating-point arithmetic (`icing`). +The `tools` directory contains dependencies used in both implementations. diff --git a/icing/CakeMLtoFloVerLemsScript.sml b/floatingPoint/icing/CakeMLtoFloVerLemsScript.sml similarity index 100% rename from icing/CakeMLtoFloVerLemsScript.sml rename to floatingPoint/icing/CakeMLtoFloVerLemsScript.sml diff --git a/icing/CakeMLtoFloVerProofsScript.sml b/floatingPoint/icing/CakeMLtoFloVerProofsScript.sml similarity index 100% rename from icing/CakeMLtoFloVerProofsScript.sml rename to floatingPoint/icing/CakeMLtoFloVerProofsScript.sml diff --git a/icing/CakeMLtoFloVerScript.sml b/floatingPoint/icing/CakeMLtoFloVerScript.sml similarity index 100% rename from icing/CakeMLtoFloVerScript.sml rename to floatingPoint/icing/CakeMLtoFloVerScript.sml diff --git a/icing/Holmakefile b/floatingPoint/icing/Holmakefile similarity index 93% rename from icing/Holmakefile rename to floatingPoint/icing/Holmakefile index 793bfa7edb..1201fce071 100644 --- a/icing/Holmakefile +++ b/floatingPoint/icing/Holmakefile @@ -4,7 +4,7 @@ INCLUDES = $(HOLDIR)/examples/formal-languages/context-free\ $(CAKEMLDIR)/semantics $(CAKEMLDIR)/characteristic\ $(CAKEMLDIR)/compiler $(CAKEMLDIR)/compiler/inference\ $(CAKEMLDIR)/compiler/backend/proofs\ - $(CAKEMLDIR)/icing/flover + $(CAKEMLDIR)/floatingPoint/tools/flover all: $(DEFAULT_TARGETS) README.md .PHONY: all diff --git a/icing/README.md b/floatingPoint/icing/README.md similarity index 98% rename from icing/README.md rename to floatingPoint/icing/README.md index c2b1398799..ce9e6b878d 100644 --- a/icing/README.md +++ b/floatingPoint/icing/README.md @@ -34,9 +34,6 @@ theorems. Translation from CakeML floating-point computations to CakeML real-number computations. -[flover](flover): -# FloVer - A Certificate Checker for Roundoff Error Bounds - [icingTacticsLib.sml](icingTacticsLib.sml): Tactic library for PrincessCake development diff --git a/icing/cfSupportScript.sml b/floatingPoint/icing/cfSupportScript.sml similarity index 100% rename from icing/cfSupportScript.sml rename to floatingPoint/icing/cfSupportScript.sml diff --git a/icing/examples/Holmakefile b/floatingPoint/icing/examples/Holmakefile similarity index 92% rename from icing/examples/Holmakefile rename to floatingPoint/icing/examples/Holmakefile index dcc22b413e..204c8f1fa3 100644 --- a/icing/examples/Holmakefile +++ b/floatingPoint/icing/examples/Holmakefile @@ -4,7 +4,7 @@ INCLUDES = $(HOLDIR)/examples/formal-languages/context-free\ $(CAKEMLDIR)/semantics $(CAKEMLDIR)/characteristic\ $(CAKEMLDIR)/compiler $(CAKEMLDIR)/compiler/inference\ $(CAKEMLDIR)/compiler/backend/semantics\ - $(CAKEMLDIR)/icing $(CAKEMLDIR)/icing/flover + $(CAKEMLDIR)/floatingPoint/icing $(CAKEMLDIR)/floatingPoint/tools/flover #Explicitly without $(DEFAULT_TARGETS) to reduce compilation time DEFAULT_TARGETS = dopplerProgCompTheory.uo diff --git a/icing/examples/README.md b/floatingPoint/icing/examples/README.md similarity index 100% rename from icing/examples/README.md rename to floatingPoint/icing/examples/README.md diff --git a/icing/examples/RungeKuttaProgCompScript.sml b/floatingPoint/icing/examples/RungeKuttaProgCompScript.sml similarity index 100% rename from icing/examples/RungeKuttaProgCompScript.sml rename to floatingPoint/icing/examples/RungeKuttaProgCompScript.sml diff --git a/icing/examples/bspline3ProgCompScript.sml b/floatingPoint/icing/examples/bspline3ProgCompScript.sml similarity index 100% rename from icing/examples/bspline3ProgCompScript.sml rename to floatingPoint/icing/examples/bspline3ProgCompScript.sml diff --git a/icing/examples/carbonGasProgCompScript.sml b/floatingPoint/icing/examples/carbonGasProgCompScript.sml similarity index 100% rename from icing/examples/carbonGasProgCompScript.sml rename to floatingPoint/icing/examples/carbonGasProgCompScript.sml diff --git a/icing/examples/carthesianToPolar_radiusProgCompScript.sml b/floatingPoint/icing/examples/carthesianToPolar_radiusProgCompScript.sml similarity index 100% rename from icing/examples/carthesianToPolar_radiusProgCompScript.sml rename to floatingPoint/icing/examples/carthesianToPolar_radiusProgCompScript.sml diff --git a/icing/examples/delta4ProgCompScript.sml b/floatingPoint/icing/examples/delta4ProgCompScript.sml similarity index 100% rename from icing/examples/delta4ProgCompScript.sml rename to floatingPoint/icing/examples/delta4ProgCompScript.sml diff --git a/icing/examples/deltaProgCompScript.sml b/floatingPoint/icing/examples/deltaProgCompScript.sml similarity index 100% rename from icing/examples/deltaProgCompScript.sml rename to floatingPoint/icing/examples/deltaProgCompScript.sml diff --git a/icing/examples/doppler1ProgCompScript.sml b/floatingPoint/icing/examples/doppler1ProgCompScript.sml similarity index 100% rename from icing/examples/doppler1ProgCompScript.sml rename to floatingPoint/icing/examples/doppler1ProgCompScript.sml diff --git a/icing/examples/doppler2ProgCompScript.sml b/floatingPoint/icing/examples/doppler2ProgCompScript.sml similarity index 100% rename from icing/examples/doppler2ProgCompScript.sml rename to floatingPoint/icing/examples/doppler2ProgCompScript.sml diff --git a/icing/examples/doppler3ProgCompScript.sml b/floatingPoint/icing/examples/doppler3ProgCompScript.sml similarity index 100% rename from icing/examples/doppler3ProgCompScript.sml rename to floatingPoint/icing/examples/doppler3ProgCompScript.sml diff --git a/icing/examples/dopplerProgCompScript.sml b/floatingPoint/icing/examples/dopplerProgCompScript.sml similarity index 100% rename from icing/examples/dopplerProgCompScript.sml rename to floatingPoint/icing/examples/dopplerProgCompScript.sml diff --git a/icing/examples/exampleLib.sml b/floatingPoint/icing/examples/exampleLib.sml similarity index 100% rename from icing/examples/exampleLib.sml rename to floatingPoint/icing/examples/exampleLib.sml diff --git a/icing/examples/himmilbeauProgCompScript.sml b/floatingPoint/icing/examples/himmilbeauProgCompScript.sml similarity index 100% rename from icing/examples/himmilbeauProgCompScript.sml rename to floatingPoint/icing/examples/himmilbeauProgCompScript.sml diff --git a/icing/examples/hypot32ProgCompScript.sml b/floatingPoint/icing/examples/hypot32ProgCompScript.sml similarity index 100% rename from icing/examples/hypot32ProgCompScript.sml rename to floatingPoint/icing/examples/hypot32ProgCompScript.sml diff --git a/icing/examples/hypotProgCompScript.sml b/floatingPoint/icing/examples/hypotProgCompScript.sml similarity index 100% rename from icing/examples/hypotProgCompScript.sml rename to floatingPoint/icing/examples/hypotProgCompScript.sml diff --git a/icing/examples/i4modifiedProgCompScript.sml b/floatingPoint/icing/examples/i4modifiedProgCompScript.sml similarity index 100% rename from icing/examples/i4modifiedProgCompScript.sml rename to floatingPoint/icing/examples/i4modifiedProgCompScript.sml diff --git a/icing/examples/intro_exampleProgCompScript.sml b/floatingPoint/icing/examples/intro_exampleProgCompScript.sml similarity index 100% rename from icing/examples/intro_exampleProgCompScript.sml rename to floatingPoint/icing/examples/intro_exampleProgCompScript.sml diff --git a/icing/examples/invertedPendulumProgCompScript.sml b/floatingPoint/icing/examples/invertedPendulumProgCompScript.sml similarity index 100% rename from icing/examples/invertedPendulumProgCompScript.sml rename to floatingPoint/icing/examples/invertedPendulumProgCompScript.sml diff --git a/icing/examples/jacobisMethodX1ProgCompScript.sml b/floatingPoint/icing/examples/jacobisMethodX1ProgCompScript.sml similarity index 100% rename from icing/examples/jacobisMethodX1ProgCompScript.sml rename to floatingPoint/icing/examples/jacobisMethodX1ProgCompScript.sml diff --git a/icing/examples/jacobisMethodX2ProgCompScript.sml b/floatingPoint/icing/examples/jacobisMethodX2ProgCompScript.sml similarity index 100% rename from icing/examples/jacobisMethodX2ProgCompScript.sml rename to floatingPoint/icing/examples/jacobisMethodX2ProgCompScript.sml diff --git a/icing/examples/jacobisMethodX3ProgCompScript.sml b/floatingPoint/icing/examples/jacobisMethodX3ProgCompScript.sml similarity index 100% rename from icing/examples/jacobisMethodX3ProgCompScript.sml rename to floatingPoint/icing/examples/jacobisMethodX3ProgCompScript.sml diff --git a/icing/examples/jacobisMethodX4ProgCompScript.sml b/floatingPoint/icing/examples/jacobisMethodX4ProgCompScript.sml similarity index 100% rename from icing/examples/jacobisMethodX4ProgCompScript.sml rename to floatingPoint/icing/examples/jacobisMethodX4ProgCompScript.sml diff --git a/icing/examples/jetEngineModifiedProgCompScript.sml b/floatingPoint/icing/examples/jetEngineModifiedProgCompScript.sml similarity index 100% rename from icing/examples/jetEngineModifiedProgCompScript.sml rename to floatingPoint/icing/examples/jetEngineModifiedProgCompScript.sml diff --git a/icing/examples/kepler0ProgCompScript.sml b/floatingPoint/icing/examples/kepler0ProgCompScript.sml similarity index 100% rename from icing/examples/kepler0ProgCompScript.sml rename to floatingPoint/icing/examples/kepler0ProgCompScript.sml diff --git a/icing/examples/kepler1ProgCompScript.sml b/floatingPoint/icing/examples/kepler1ProgCompScript.sml similarity index 100% rename from icing/examples/kepler1ProgCompScript.sml rename to floatingPoint/icing/examples/kepler1ProgCompScript.sml diff --git a/icing/examples/kepler2ProgCompScript.sml b/floatingPoint/icing/examples/kepler2ProgCompScript.sml similarity index 100% rename from icing/examples/kepler2ProgCompScript.sml rename to floatingPoint/icing/examples/kepler2ProgCompScript.sml diff --git a/icing/examples/matrixDeterminant2ProgCompScript.sml b/floatingPoint/icing/examples/matrixDeterminant2ProgCompScript.sml similarity index 100% rename from icing/examples/matrixDeterminant2ProgCompScript.sml rename to floatingPoint/icing/examples/matrixDeterminant2ProgCompScript.sml diff --git a/icing/examples/matrixDeterminant2modifiedProgCompScript.sml b/floatingPoint/icing/examples/matrixDeterminant2modifiedProgCompScript.sml similarity index 100% rename from icing/examples/matrixDeterminant2modifiedProgCompScript.sml rename to floatingPoint/icing/examples/matrixDeterminant2modifiedProgCompScript.sml diff --git a/icing/examples/matrixDeterminantProgCompScript.sml b/floatingPoint/icing/examples/matrixDeterminantProgCompScript.sml similarity index 100% rename from icing/examples/matrixDeterminantProgCompScript.sml rename to floatingPoint/icing/examples/matrixDeterminantProgCompScript.sml diff --git a/icing/examples/n_bodyXmodifiedProgCompScript.sml b/floatingPoint/icing/examples/n_bodyXmodifiedProgCompScript.sml similarity index 100% rename from icing/examples/n_bodyXmodifiedProgCompScript.sml rename to floatingPoint/icing/examples/n_bodyXmodifiedProgCompScript.sml diff --git a/icing/examples/n_bodyZmodifiedProgCompScript.sml b/floatingPoint/icing/examples/n_bodyZmodifiedProgCompScript.sml similarity index 100% rename from icing/examples/n_bodyZmodifiedProgCompScript.sml rename to floatingPoint/icing/examples/n_bodyZmodifiedProgCompScript.sml diff --git a/icing/examples/nn1LayerProgCompScript.sml b/floatingPoint/icing/examples/nn1LayerProgCompScript.sml similarity index 100% rename from icing/examples/nn1LayerProgCompScript.sml rename to floatingPoint/icing/examples/nn1LayerProgCompScript.sml diff --git a/icing/examples/nonlin1ProgCompScript.sml b/floatingPoint/icing/examples/nonlin1ProgCompScript.sml similarity index 100% rename from icing/examples/nonlin1ProgCompScript.sml rename to floatingPoint/icing/examples/nonlin1ProgCompScript.sml diff --git a/icing/examples/nonlin2ProgCompScript.sml b/floatingPoint/icing/examples/nonlin2ProgCompScript.sml similarity index 100% rename from icing/examples/nonlin2ProgCompScript.sml rename to floatingPoint/icing/examples/nonlin2ProgCompScript.sml diff --git a/icing/examples/output/Holmakefile b/floatingPoint/icing/examples/output/Holmakefile similarity index 100% rename from icing/examples/output/Holmakefile rename to floatingPoint/icing/examples/output/Holmakefile diff --git a/icing/examples/output/README.md b/floatingPoint/icing/examples/output/README.md similarity index 100% rename from icing/examples/output/README.md rename to floatingPoint/icing/examples/output/README.md diff --git a/icing/examples/output/readmePrefix b/floatingPoint/icing/examples/output/readmePrefix similarity index 100% rename from icing/examples/output/readmePrefix rename to floatingPoint/icing/examples/output/readmePrefix diff --git a/icing/examples/pidProgCompScript.sml b/floatingPoint/icing/examples/pidProgCompScript.sml similarity index 100% rename from icing/examples/pidProgCompScript.sml rename to floatingPoint/icing/examples/pidProgCompScript.sml diff --git a/icing/examples/predatorPreyProgCompScript.sml b/floatingPoint/icing/examples/predatorPreyProgCompScript.sml similarity index 100% rename from icing/examples/predatorPreyProgCompScript.sml rename to floatingPoint/icing/examples/predatorPreyProgCompScript.sml diff --git a/icing/examples/readmePrefix b/floatingPoint/icing/examples/readmePrefix similarity index 100% rename from icing/examples/readmePrefix rename to floatingPoint/icing/examples/readmePrefix diff --git a/icing/examples/rigidBody1ProgCompScript.sml b/floatingPoint/icing/examples/rigidBody1ProgCompScript.sml similarity index 100% rename from icing/examples/rigidBody1ProgCompScript.sml rename to floatingPoint/icing/examples/rigidBody1ProgCompScript.sml diff --git a/icing/examples/rigidBody2ProgCompScript.sml b/floatingPoint/icing/examples/rigidBody2ProgCompScript.sml similarity index 100% rename from icing/examples/rigidBody2ProgCompScript.sml rename to floatingPoint/icing/examples/rigidBody2ProgCompScript.sml diff --git a/icing/examples/rigidBodyProgCompScript.sml b/floatingPoint/icing/examples/rigidBodyProgCompScript.sml similarity index 100% rename from icing/examples/rigidBodyProgCompScript.sml rename to floatingPoint/icing/examples/rigidBodyProgCompScript.sml diff --git a/icing/examples/rump_from_CProgCompScript.sml b/floatingPoint/icing/examples/rump_from_CProgCompScript.sml similarity index 100% rename from icing/examples/rump_from_CProgCompScript.sml rename to floatingPoint/icing/examples/rump_from_CProgCompScript.sml diff --git a/icing/examples/rump_revisitedProgCompScript.sml b/floatingPoint/icing/examples/rump_revisitedProgCompScript.sml similarity index 100% rename from icing/examples/rump_revisitedProgCompScript.sml rename to floatingPoint/icing/examples/rump_revisitedProgCompScript.sml diff --git a/icing/examples/rump_with_powProgCompScript.sml b/floatingPoint/icing/examples/rump_with_powProgCompScript.sml similarity index 100% rename from icing/examples/rump_with_powProgCompScript.sml rename to floatingPoint/icing/examples/rump_with_powProgCompScript.sml diff --git a/icing/examples/runge_kutta_4ProgCompScript.sml b/floatingPoint/icing/examples/runge_kutta_4ProgCompScript.sml similarity index 100% rename from icing/examples/runge_kutta_4ProgCompScript.sml rename to floatingPoint/icing/examples/runge_kutta_4ProgCompScript.sml diff --git a/icing/examples/sec4_exampleProgCompScript.sml b/floatingPoint/icing/examples/sec4_exampleProgCompScript.sml similarity index 100% rename from icing/examples/sec4_exampleProgCompScript.sml rename to floatingPoint/icing/examples/sec4_exampleProgCompScript.sml diff --git a/icing/examples/sineOrder3ProgCompScript.sml b/floatingPoint/icing/examples/sineOrder3ProgCompScript.sml similarity index 100% rename from icing/examples/sineOrder3ProgCompScript.sml rename to floatingPoint/icing/examples/sineOrder3ProgCompScript.sml diff --git a/icing/examples/sineProgCompScript.sml b/floatingPoint/icing/examples/sineProgCompScript.sml similarity index 100% rename from icing/examples/sineProgCompScript.sml rename to floatingPoint/icing/examples/sineProgCompScript.sml diff --git a/icing/examples/sine_newtonProgCompScript.sml b/floatingPoint/icing/examples/sine_newtonProgCompScript.sml similarity index 100% rename from icing/examples/sine_newtonProgCompScript.sml rename to floatingPoint/icing/examples/sine_newtonProgCompScript.sml diff --git a/icing/examples/sqrootProgCompScript.sml b/floatingPoint/icing/examples/sqrootProgCompScript.sml similarity index 100% rename from icing/examples/sqrootProgCompScript.sml rename to floatingPoint/icing/examples/sqrootProgCompScript.sml diff --git a/icing/examples/sqrt_addProgCompScript.sml b/floatingPoint/icing/examples/sqrt_addProgCompScript.sml similarity index 100% rename from icing/examples/sqrt_addProgCompScript.sml rename to floatingPoint/icing/examples/sqrt_addProgCompScript.sml diff --git a/icing/examples/sumProgCompScript.sml b/floatingPoint/icing/examples/sumProgCompScript.sml similarity index 100% rename from icing/examples/sumProgCompScript.sml rename to floatingPoint/icing/examples/sumProgCompScript.sml diff --git a/icing/examples/test01_sum3ProgCompScript.sml b/floatingPoint/icing/examples/test01_sum3ProgCompScript.sml similarity index 100% rename from icing/examples/test01_sum3ProgCompScript.sml rename to floatingPoint/icing/examples/test01_sum3ProgCompScript.sml diff --git a/icing/examples/test02_sum8ProgCompScript.sml b/floatingPoint/icing/examples/test02_sum8ProgCompScript.sml similarity index 100% rename from icing/examples/test02_sum8ProgCompScript.sml rename to floatingPoint/icing/examples/test02_sum8ProgCompScript.sml diff --git a/icing/examples/test03_nonlin2ProgCompScript.sml b/floatingPoint/icing/examples/test03_nonlin2ProgCompScript.sml similarity index 100% rename from icing/examples/test03_nonlin2ProgCompScript.sml rename to floatingPoint/icing/examples/test03_nonlin2ProgCompScript.sml diff --git a/icing/examples/test04_dqmom9ProgCompScript.sml b/floatingPoint/icing/examples/test04_dqmom9ProgCompScript.sml similarity index 100% rename from icing/examples/test04_dqmom9ProgCompScript.sml rename to floatingPoint/icing/examples/test04_dqmom9ProgCompScript.sml diff --git a/icing/examples/test05_nonlin1_r4ProgCompScript.sml b/floatingPoint/icing/examples/test05_nonlin1_r4ProgCompScript.sml similarity index 100% rename from icing/examples/test05_nonlin1_r4ProgCompScript.sml rename to floatingPoint/icing/examples/test05_nonlin1_r4ProgCompScript.sml diff --git a/icing/examples/test05_nonlin1_test2ProgCompScript.sml b/floatingPoint/icing/examples/test05_nonlin1_test2ProgCompScript.sml similarity index 100% rename from icing/examples/test05_nonlin1_test2ProgCompScript.sml rename to floatingPoint/icing/examples/test05_nonlin1_test2ProgCompScript.sml diff --git a/icing/examples/test06_sums4_sum1ProgCompScript.sml b/floatingPoint/icing/examples/test06_sums4_sum1ProgCompScript.sml similarity index 100% rename from icing/examples/test06_sums4_sum1ProgCompScript.sml rename to floatingPoint/icing/examples/test06_sums4_sum1ProgCompScript.sml diff --git a/icing/examples/test06_sums4_sum2ProgCompScript.sml b/floatingPoint/icing/examples/test06_sums4_sum2ProgCompScript.sml similarity index 100% rename from icing/examples/test06_sums4_sum2ProgCompScript.sml rename to floatingPoint/icing/examples/test06_sums4_sum2ProgCompScript.sml diff --git a/icing/examples/turbine1ProgCompScript.sml b/floatingPoint/icing/examples/turbine1ProgCompScript.sml similarity index 100% rename from icing/examples/turbine1ProgCompScript.sml rename to floatingPoint/icing/examples/turbine1ProgCompScript.sml diff --git a/icing/examples/turbine2ProgCompScript.sml b/floatingPoint/icing/examples/turbine2ProgCompScript.sml similarity index 100% rename from icing/examples/turbine2ProgCompScript.sml rename to floatingPoint/icing/examples/turbine2ProgCompScript.sml diff --git a/icing/examples/turbine3ProgCompScript.sml b/floatingPoint/icing/examples/turbine3ProgCompScript.sml similarity index 100% rename from icing/examples/turbine3ProgCompScript.sml rename to floatingPoint/icing/examples/turbine3ProgCompScript.sml diff --git a/icing/examples/verhulstProgCompScript.sml b/floatingPoint/icing/examples/verhulstProgCompScript.sml similarity index 100% rename from icing/examples/verhulstProgCompScript.sml rename to floatingPoint/icing/examples/verhulstProgCompScript.sml diff --git a/icing/examples/x_by_xyProgCompScript.sml b/floatingPoint/icing/examples/x_by_xyProgCompScript.sml similarity index 100% rename from icing/examples/x_by_xyProgCompScript.sml rename to floatingPoint/icing/examples/x_by_xyProgCompScript.sml diff --git a/icing/floatToRealProofsScript.sml b/floatingPoint/icing/floatToRealProofsScript.sml similarity index 100% rename from icing/floatToRealProofsScript.sml rename to floatingPoint/icing/floatToRealProofsScript.sml diff --git a/icing/floatToRealScript.sml b/floatingPoint/icing/floatToRealScript.sml similarity index 100% rename from icing/floatToRealScript.sml rename to floatingPoint/icing/floatToRealScript.sml diff --git a/icing/icingTacticsLib.sml b/floatingPoint/icing/icingTacticsLib.sml similarity index 100% rename from icing/icingTacticsLib.sml rename to floatingPoint/icing/icingTacticsLib.sml diff --git a/icing/icing_optimisationProofsScript.sml b/floatingPoint/icing/icing_optimisationProofsScript.sml similarity index 100% rename from icing/icing_optimisationProofsScript.sml rename to floatingPoint/icing/icing_optimisationProofsScript.sml diff --git a/icing/icing_optimisationsLib.sml b/floatingPoint/icing/icing_optimisationsLib.sml similarity index 100% rename from icing/icing_optimisationsLib.sml rename to floatingPoint/icing/icing_optimisationsLib.sml diff --git a/icing/icing_optimisationsScript.sml b/floatingPoint/icing/icing_optimisationsScript.sml similarity index 100% rename from icing/icing_optimisationsScript.sml rename to floatingPoint/icing/icing_optimisationsScript.sml diff --git a/icing/icing_realIdProofsScript.sml b/floatingPoint/icing/icing_realIdProofsScript.sml similarity index 100% rename from icing/icing_realIdProofsScript.sml rename to floatingPoint/icing/icing_realIdProofsScript.sml diff --git a/icing/icing_rewriterProofsScript.sml b/floatingPoint/icing/icing_rewriterProofsScript.sml similarity index 100% rename from icing/icing_rewriterProofsScript.sml rename to floatingPoint/icing/icing_rewriterProofsScript.sml diff --git a/icing/icing_rewriterScript.sml b/floatingPoint/icing/icing_rewriterScript.sml similarity index 100% rename from icing/icing_rewriterScript.sml rename to floatingPoint/icing/icing_rewriterScript.sml diff --git a/icing/new_backendProofScript.sml b/floatingPoint/icing/new_backendProofScript.sml similarity index 100% rename from icing/new_backendProofScript.sml rename to floatingPoint/icing/new_backendProofScript.sml diff --git a/icing/optPlannerProofsScript.sml b/floatingPoint/icing/optPlannerProofsScript.sml similarity index 100% rename from icing/optPlannerProofsScript.sml rename to floatingPoint/icing/optPlannerProofsScript.sml diff --git a/icing/optPlannerScript.sml b/floatingPoint/icing/optPlannerScript.sml similarity index 100% rename from icing/optPlannerScript.sml rename to floatingPoint/icing/optPlannerScript.sml diff --git a/icing/pull_wordsScript.sml b/floatingPoint/icing/pull_wordsScript.sml similarity index 99% rename from icing/pull_wordsScript.sml rename to floatingPoint/icing/pull_wordsScript.sml index 1e1b1e85ef..53e26fe609 100644 --- a/icing/pull_wordsScript.sml +++ b/floatingPoint/icing/pull_wordsScript.sml @@ -1316,6 +1316,7 @@ Proof >- trivial_tac >- trivial_tac >- trivial_tac + >- trivial_tac >- ( rpt strip_tac >> ‘LENGTH a1 = LENGTH a2’ by (irule LIST_REL_LENGTH >> asm_exists_tac >> gs[]) diff --git a/icing/pureExpsScript.sml b/floatingPoint/icing/pureExpsScript.sml similarity index 100% rename from icing/pureExpsScript.sml rename to floatingPoint/icing/pureExpsScript.sml diff --git a/icing/readmePrefix b/floatingPoint/icing/readmePrefix similarity index 100% rename from icing/readmePrefix rename to floatingPoint/icing/readmePrefix diff --git a/icing/source_to_source2ProofsScript.sml b/floatingPoint/icing/source_to_source2ProofsScript.sml similarity index 100% rename from icing/source_to_source2ProofsScript.sml rename to floatingPoint/icing/source_to_source2ProofsScript.sml diff --git a/icing/source_to_source2Script.sml b/floatingPoint/icing/source_to_source2Script.sml similarity index 100% rename from icing/source_to_source2Script.sml rename to floatingPoint/icing/source_to_source2Script.sml diff --git a/icing/supportLib.sml b/floatingPoint/icing/supportLib.sml similarity index 100% rename from icing/supportLib.sml rename to floatingPoint/icing/supportLib.sml diff --git a/floatingPoint/libmGen/FloVerToCakeMLProofsScript.sml b/floatingPoint/libmGen/FloVerToCakeMLProofsScript.sml new file mode 100644 index 0000000000..56946760d7 --- /dev/null +++ b/floatingPoint/libmGen/FloVerToCakeMLProofsScript.sml @@ -0,0 +1,261 @@ +(* + Main connection theorem relating FloVer's roundoff error bound + to CakeML floating-point kernel executions +*) +(* HOL4 *) +open machine_ieeeTheory realTheory realLib RealArith; +(* CakeML *) +open fpValTreeTheory fpSemTheory realOpsTheory semanticPrimitivesTheory + evaluateTheory ml_translatorTheory; +(* Icing *) +open floatToRealTheory FloVerToCakeMLTheory CakeMLtoFloVerProofsTheory; +(* FloVer *) +open ResultsTheory ExpressionsTheory ExpressionSemanticsTheory CommandsTheory + EnvironmentsTheory IEEE_connectionTheory IEEE_reverseTheory + FloverMapTheory TypeValidatorTheory MachineTypeTheory; +open preamble; + +val _ = new_theory "FloVerToCakeMLProofs"; + +Definition usedVars_P_sound_def: + usedVars_P_sound e (env:(string,string,v) namespace) P = + ∀ x. + x IN domain (usedVars e) ⇒ + ∃ fp. + nsLookup env (Short ("x" ++ (toString x))) = SOME (FP_WordTree fp) ∧ + fp64_isFinite (compress_word fp) ∧ + FST (P x) ≤ fp64_to_real (compress_word fp) ∧ + fp64_to_real (compress_word fp) ≤ SND (P x) +End + +Definition toFloVerEnv_def: + toFloVerEnv (env:(string,string,v) namespace) e = + λ (n:num). + case lookup n (usedVars e) of + NONE => NONE + | SOME () => + case nsLookup env $ Short ("x" ++ (toString n)) of + | NONE => NONE + | SOME $ FP_WordTree fp => SOME $ compress_word fp + | SOME _ => NONE +End + +Theorem validTypes_usedVars: + ∀ e Gamma x. + validTypes e Gamma ∧ + x IN domain (usedVars e) ⇒ + ∃ m. toRExpMap Gamma (Var x) = SOME m +Proof + ho_match_mp_tac validTypes_ind >> rpt strip_tac + >> Cases_on ‘e’ >> gs[] + >- gs[validTypes_def, ExpressionAbbrevsTheory.toRExpMap_def, Once usedVars_def] + >- gs[Once usedVars_def] + >- ( + first_x_assum irule + >> gs[Once validTypes_def, Once usedVars_def]) + >~ [‘Binop b e1 e2’] + >- ( + qpat_x_assum ‘validTypes _ _’ mp_tac + >> simp[Once validTypes_def] >> strip_tac >> gs[] + >> ‘x IN domain (usedVars e1) ∨ x IN domain (usedVars e2)’ + by (qpat_x_assum ‘x IN domain _’ mp_tac >> simp[Once usedVars_def, domain_union]) + >> gs[]) + >~ [‘Fma e1 e2 e3’] + >- ( + qpat_x_assum ‘validTypes _ _’ mp_tac + >> simp[Once validTypes_def] >> strip_tac >> gs[] + >> ‘x IN domain (usedVars e1) ∨ x IN domain (usedVars e2) ∨ x IN domain (usedVars e3)’ + by (qpat_x_assum ‘x IN domain _’ mp_tac >> simp[Once usedVars_def, domain_union]) + >> gs[]) + >> first_x_assum irule + >> gs[Once usedVars_def, Once validTypes_def] +QED + +Theorem approxEnv_toFloVerEnv: + ∀ (e:real expr) env P Gamma (A:analysisResult). + validTypes e Gamma ∧ + usedVars_P_sound (e:real expr) env P ⇒ + approxEnv (toREnv (toFloVerEnv env e)) (toRExpMap Gamma) A (usedVars e) LN (toREnv (toFloVerEnv env e)) +Proof + rpt strip_tac >> irule approxEnv_refl >> rw [toFloVerEnv_def, toREnv_def] + >- ( + CASE_TAC >> gs[domain_lookup] + >- (CASE_TAC >> gs[]) + >> Cases_on ‘lookup x (usedVars e)’ >> gs[]) + >- (drule validTypes_usedVars >> gs[]) + >> gs[domain_lookup, usedVars_P_sound_def] + >> res_tac >> gs[] +QED + +Theorem usedVars_P_sound_fVars_P_sound: + usedVars_P_sound e flEnv P ⇒ + fVars_P_sound (usedVars e) (toREnv (toFloVerEnv flEnv e)) P +Proof + rw[usedVars_P_sound_def, RealRangeArithTheory.fVars_P_sound_def, + toFloVerEnv_def, toREnv_def] + >> res_tac >> gs[domain_lookup, fp64_to_real_def] +QED + +Definition float_env_rel_def: + float_env_rel (E:num -> word64 option) env vars = + ∀ x v. + x IN vars ∧ + E x = SOME v ⇒ + ∃ fp. + nsLookup env (Short $ STRCAT "x" (toString x)) = SOME (FP_WordTree fp) ∧ + v = compress_word fp +End + +Theorem FloVer_to_CML_float_sim: + ∀ e prog st E env flEnv vF fVars. + SOME prog = toCmlFloatExp e ∧ + st.fp_state.canOpt ≠ FPScope Opt ∧ + domain $ usedVars e SUBSET fVars ∧ + float_env_rel E flEnv fVars ∧ + eval_expr_float (toFlExp e) E = SOME vF ⇒ + ∃ fp. + evaluate st (env with v := nsAppend flEnv env.v) [prog] = + (st, Rval [FP_WordTree fp]) ∧ + compress_word fp = vF +Proof + ho_match_mp_tac toCmlFloatExp_ind >> rw[toCmlFloatExp_def] + >> gs[eval_expr_float_def, toFlExp_def] + >> simp[Once evaluate_def] + >- ( + gvs[toFlEnv_def, float_env_rel_def, CaseEq"option"] + >> ‘i IN fVars’ by gs[Once usedVars_def, SUBSET_DEF] + >> res_tac + >> gvs[namespacePropsTheory.nsLookup_nsMap, + namespacePropsTheory.nsLookup_nsAppend_some]) + >- gvs[perturb_def, evaluate_def, do_app_def, state_component_equality, + compress_word_def, real_to_fp64_def] + >- ( + gvs[CaseEq"option", evaluate_def, astTheory.isFpBool_def] + >> ‘domain (usedVars e) SUBSET fVars’ by ( + qpat_x_assum ‘domain _ SUBSET _’ mp_tac + >> simp[Once usedVars_def]) + >> last_x_assum $ drule_then drule + >> rpt $ disch_then drule + >> disch_then $ qspec_then ‘env’ strip_assume_tac + >> gs[do_app_def, real_uop_def, getRealUop_def, evalUnop_def, + state_component_equality, semanticPrimitivesTheory.fp_translate_def, + compress_word_def, fp_uop_def, fp_uop_comp_def]) + >- ( + gvs[CaseEq"option", evaluate_def, astTheory.isFpBool_def] + >> rename1 ‘domain (usedVars (Binop bop e1 e2)) SUBSET fVars’ + >> ‘domain (usedVars e1) SUBSET fVars ∧ + domain (usedVars e2) SUBSET fVars’ by ( + qpat_x_assum ‘domain _ SUBSET _’ mp_tac + >> simp[Once usedVars_def, domain_union]) + >> ntac 2 ( + last_x_assum $ drule_then drule + >> rpt $ disch_then drule >> disch_then $ qspec_then ‘env’ strip_assume_tac) + >> simp[do_app_def, state_component_equality, fp_translate_def] + >> Cases_on ‘bop’ + >> gvs[fp_bop_def, fp_bop_comp_def, bopTofpBop_def, compress_word_def, + dmode_def]) + >- ( + gvs[CaseEq"option", evaluate_def, astTheory.isFpBool_def] + >> rename1 ‘domain (usedVars (Fma e1 e2 e3)) SUBSET fVars’ + >> ‘domain (usedVars e1) SUBSET fVars ∧ domain (usedVars e2) SUBSET fVars ∧ + domain (usedVars e3) SUBSET fVars’ by ( + qpat_x_assum ‘domain _ SUBSET _’ mp_tac + >> simp[Once usedVars_def, domain_union]) + >> ntac 3 ( + last_x_assum $ drule_then drule + >> rpt $ disch_then drule >> disch_then $ qspec_then ‘env’ assume_tac) + >> gvs[evaluate_def, do_app_def, state_component_equality, fp_translate_def, + compress_word_def, fp_top_def, fp_top_comp_def, fpfma_def]) +QED + +Theorem FloVer_to_CML_float_sim_strong: + ∀ e prog st E env flEnv vF fVars. + SOME prog = toCmlFloatProg e ∧ + domain $ usedVars e SUBSET fVars ∧ + float_env_rel E flEnv fVars ∧ + eval_expr_float (toFlExp e) E = SOME vF ⇒ + ∃ fp. + evaluate st (env with v := nsAppend flEnv env.v) [prog] = + (st, Rval [FP_WordTree fp]) ∧ + compress_word fp = vF +Proof + rw[CaseEq"option", toCmlFloatProg_def] + >> simp[Once evaluate_def] + >> last_x_assum $ assume_tac o GSYM + >> drule FloVer_to_CML_float_sim + >> qmatch_goalsub_abbrev_tac ‘evaluate stN _ [p]’ + >> ‘stN.fp_state.canOpt ≠ FPScope Opt’ + by (unabbrev_all_tac >> COND_CASES_TAC >> gs[]) + >> rpt $ disch_then $ drule + >> disch_then $ qspec_then ‘env’ strip_assume_tac >> gvs[] + >> unabbrev_all_tac >> gvs[state_component_equality, fpState_component_equality] + >> COND_CASES_TAC >> gvs[do_fpoptimise_def, compress_word_def] +QED + +Theorem usedVars_ratExp2realExp: + ∀ e. usedVars e = usedVars $ ratExp2realExp e +Proof + ho_match_mp_tac usedVars_ind >> rw[] + >> Cases_on ‘e’ >> gs[ratExp2realExp_def] + >- simp[usedVars_def] + >- (Cases_on ‘v’ >> simp[ratExp2realExp_def] + >> simp[usedVars_def]) + >> simp[Once usedVars_def] >> EVAL_TAC +QED + +Theorem FloVer_CakeML_sound_error: + ∀ eReal progFloat flEnv A P defVars Gamma env + (st:'ffi semanticPrimitives$state). + SOME progFloat = toCmlFloatProg eReal ∧ + is64BitEval eReal ∧ noDowncast eReal ∧ + is64BitEnv defVars ∧ + CertificateChecker eReal A P defVars = SOME Gamma ∧ + usedVars_P_sound eReal flEnv P ⇒ + ∃ r fp err iv. + FloverMapTree_find eReal A = SOME (iv,err) ∧ + (* the CakeML code returns a valid floating-point word *) + eval_expr (toREnv (toFloVerEnv flEnv eReal)) + (λ e. SOME REAL) + (toREval eReal) r REAL ∧ + evaluate st (env with v := (nsAppend flEnv env.v)) [progFloat] = + (st, Rval [FP_WordTree fp]) /\ + (* the roundoff error is sound *) + realax$abs (r - fp64_to_real (compress_word fp)) ≤ err +Proof + rpt strip_tac + >> first_assum $ mp_then Any assume_tac usedVars_P_sound_fVars_P_sound + >> ‘validTypes eReal Gamma’ by ( + qpat_x_assum ‘CertificateChecker _ _ _ _ = _’ mp_tac + >> simp[CertificateCheckerTheory.CertificateChecker_def] + >> TOP_CASE_TAC >> rw[] + >> irule getValidMap_top_correct + >> first_x_assum $ irule_at Any >> rpt strip_tac + >> gs[FloverMapTree_mem_def, FloverMapTree_empty_def, FloverMapTree_find_def]) + >> drule IEEE_reverseTheory.IEEE_connection_expr + >> rpt $ disch_then drule >> gs[SUBSET_REFL] + >> disch_then drule + >> disch_then $ qspec_then ‘toFloVerEnv flEnv eReal’ mp_tac + >> impl_tac + >- (drule_then drule approxEnv_toFloVerEnv >> gs[]) + >> rpt strip_tac + >> first_x_assum $ irule_at Any + >> drule $ INST_TYPE [alpha|-> “:'ffi”] FloVer_to_CML_float_sim_strong + >> disch_then $ qspecl_then [‘st’,‘toFloVerEnv flEnv eReal’, ‘env’, + ‘flEnv’, ‘vF’, ‘domain $ usedVars eReal’] mp_tac + >> impl_tac + >- ( + unabbrev_all_tac + >> rw[float_env_rel_def, toFloVerEnv_def, CaseEqs["option", "v"]] + >> first_assum $ irule_at Any >> gs[]) + >> strip_tac + >> gvs[] + >> first_x_assum $ irule_at Any + >> irule ExpressionSemanticsTheory.swap_gamma_eval_weak + >> first_x_assum $ irule_at Any + >> rpt gen_tac + >> Cases_on ‘e’ + >> gs[ExpressionAbbrevsTheory.toRTMap_def] + >> TOP_CASE_TAC >> gs[] +QED + +val _ = export_theory(); diff --git a/floatingPoint/libmGen/FloVerToCakeMLScript.sml b/floatingPoint/libmGen/FloVerToCakeMLScript.sml new file mode 100644 index 0000000000..3f07359521 --- /dev/null +++ b/floatingPoint/libmGen/FloVerToCakeMLScript.sml @@ -0,0 +1,118 @@ +(* + Translation from CakeML floating-point kernels to FloVer input +*) + +(* HOL *) +open binary_ieeeTheory machine_ieeeTheory lift_ieeeTheory; +(* CakeML *) +open astTheory; +(* FloVer *) +open ExpressionsTheory IEEE_connectionTheory; +(* Dandelion *) +open checkerDefsTheory; +open preamble; + +val _ = new_theory "FloVerToCakeML"; + +(** Translation from FloVer AST to CakeML AST **) +Definition bopTofpBop_def: + bopTofpBop Expressions$Plus = FP_Add ∧ + bopTofpBop Sub = FP_Sub ∧ + bopTofpBop Mult = FP_Mul ∧ + bopTofpBop Div = FP_Div +End + +Definition toFloVerFloatExp_def: + toFloVerFloatExp (Expressions$Var i) = Expressions$Var i ∧ + toFloVerFloatExp (Const m c) = Const M64 c ∧ + toFloVerFloatExp (Unop Neg e) = Unop Neg (toFloVerFloatExp e) ∧ + toFloVerFloatExp (Binop b e1 e2) = + Binop b (toFloVerFloatExp e1) (toFloVerFloatExp e2) ∧ + toFloVerFloatExp (Fma e1 e2 e3) = + Fma (toFloVerFloatExp e1) (toFloVerFloatExp e2) (toFloVerFloatExp e3) ∧ + toFloVerFloatExp (Downcast m e) = + Downcast M64 (toFloVerFloatExp e) +End + +Definition toCmlFloatExp_def: + toCmlFloatExp (Expressions$Var i):ast$exp option = + SOME $ ast$Var (Short ("x" ++ (toString i))) ∧ + toCmlFloatExp (Const M64 c) = + SOME $ App FpFromWord [Lit (Word64 (float_to_fp64 ((real_to_float dmode c):(52, 11) float)))] ∧ + toCmlFloatExp (Unop Neg e) = + (case toCmlFloatExp e of + | NONE => NONE + | SOME e1 => SOME $ App (FP_uop FP_Neg) [e1]) ∧ + toCmlFloatExp (Binop op e1 e2) = + (case toCmlFloatExp e1 of + | NONE => NONE + | SOME e1F => + case toCmlFloatExp e2 of + | NONE => NONE + | SOME e2F => + SOME $ App (FP_bop (bopTofpBop op)) [e1F; e2F]) ∧ + toCmlFloatExp (Fma e1 e2 e3) = + (case toCmlFloatExp e1 of + | NONE => NONE + | SOME e1F => + case toCmlFloatExp e2 of + | NONE => NONE + | SOME e2F => + case toCmlFloatExp e3 of + | NONE => NONE + | SOME e3F => + SOME $ App (FP_top FP_Fma) [e3F; e1F; e2F]) ∧ + toCmlFloatExp _ = NONE +End + +Definition toCmlFloatProg_def: + toCmlFloatProg e = + case toCmlFloatExp e of + | NONE => NONE + | SOME p => SOME $ FpOptimise NoOpt p +End + +Definition bopToRealBop_def: + bopToRealBop Expressions$Plus = Real_Add ∧ + bopToRealBop Sub = Real_Sub ∧ + bopToRealBop Mult = Real_Mul ∧ + bopToRealBop Div = Real_Div +End + +Definition toCmlRealExp_def: + toCmlRealExp (Expressions$Var i):ast$exp option = + SOME $ ast$Var (Short ("x" ++ (toString i))) ∧ + (** FIXME **) + toCmlRealExp (Const M64 (c,d)) = + SOME $ App (RealFromIntProd) [Lit (IntLit c); Lit (IntLit d)] ∧ + toCmlRealExp (Unop Neg e) = + (case toCmlRealExp e of + | NONE => NONE + | SOME e1 => SOME $ App (Real_uop Real_Neg) [e1]) ∧ + toCmlRealExp (Binop op e1 e2) = + (case toCmlRealExp e1 of + | NONE => NONE + | SOME e1R => + case toCmlRealExp e2 of + | NONE => NONE + | SOME e2R => + SOME $ App (Real_bop (bopToRealBop op)) [e1R; e2R]) ∧ + toCmlRealExp (Fma e1 e2 e3) = + (case toCmlRealExp e1 of + | NONE => NONE + | SOME e1R => + case toCmlRealExp e2 of + | NONE => NONE + | SOME e2R => + case toCmlRealExp e3 of + | NONE => NONE + | SOME e3R => + SOME $ App (Real_bop Real_Add) [App (Real_bop Real_Mul) [e1R; e2R]; e3R]) ∧ + toCmlRealExp _ = NONE +End + +Definition getPrecondFromCert_def: + getPrecondFromCert cert = λ (x:num). if x = 0 then SND (HD cert.iv) else (0,0:real) +End + +val _ = export_theory (); diff --git a/floatingPoint/libmGen/Holmakefile b/floatingPoint/libmGen/Holmakefile new file mode 100644 index 0000000000..8b9f133703 --- /dev/null +++ b/floatingPoint/libmGen/Holmakefile @@ -0,0 +1,18 @@ +INCLUDES = $(HOLDIR)/examples/formal-languages/context-free\ + $(CAKEMLDIR)/developers $(CAKEMLDIR)/misc\ + $(CAKEMLDIR)/unverified/sexpr-bootstrap\ + $(CAKEMLDIR)/semantics $(CAKEMLDIR)/characteristic\ + $(CAKEMLDIR)/floatingPoint/tools/flover\ + $(CAKEMLDIR)/floatingPoint/tools/dandelion\ + $(CAKEMLDIR)/floatingPoint/icing + + +#Explicitly without $(DEFAULT_TARGETS) to reduce compilation time +DEFAULT_TARGETS = atnDeg3Theory.sig +all: $(DEFAULT_TARGETS) README.md +.PHONY: all + +README_SOURCES = $(wildcard *Script.sml) $(wildcard *Lib.sml) $(wildcard *Syntax.sml) +DIRS = $(wildcard */) +README.md: $(CAKEMLDIR)/developers/readme_gen readmePrefix $(patsubst %,%readmePrefix,$(DIRS)) $(README_SOURCES) + $(CAKEMLDIR)/developers/readme_gen $(README_SOURCES) diff --git a/floatingPoint/libmGen/README.md b/floatingPoint/libmGen/README.md new file mode 100644 index 0000000000..6f2799dd3b --- /dev/null +++ b/floatingPoint/libmGen/README.md @@ -0,0 +1,25 @@ +A libm-generator for CakeML that uses Dandelion and FloVer from `tools` +to prove a specification that relates CakeML code to the real-valued elementary +function. + +[FloVerToCakeMLProofsScript.sml](FloVerToCakeMLProofsScript.sml): +Main connection theorem relating FloVer's roundoff error bound +to CakeML floating-point kernel executions + +[FloVerToCakeMLScript.sml](FloVerToCakeMLScript.sml): +Translation from CakeML floating-point kernels to FloVer input + +[cosExampleScript.sml](cosExampleScript.sml): +Example libm function generated from cosine certificate of Dandelion + +[expExampleScript.sml](expExampleScript.sml): +Example libm function generated from cosine certificate of Dandelion + +[libmLib.sml](libmLib.sml): +Implementation of automatic generation of libm functions + +[libmScript.sml](libmScript.sml): +Supporting proofs for automation + +[sinExampleScript.sml](sinExampleScript.sml): +Example libm function generated from sine certificate of Dandelion diff --git a/floatingPoint/libmGen/atnDeg3Script.sml b/floatingPoint/libmGen/atnDeg3Script.sml new file mode 100644 index 0000000000..84c1725a15 --- /dev/null +++ b/floatingPoint/libmGen/atnDeg3Script.sml @@ -0,0 +1,31 @@ +(** + Example file for libmGen, generates an approximation of + tan^-1 with degree 3 +**) +open realZeroLib bitArithLib libmLib preambleDandelion; + +val _ = new_theory "atnDeg3"; + +val _ = realZeroLib.useBinary := false; +val _ = realZeroLib.createMetiTarskiQuery := false; + +Definition cos_example_def: + cos_example = + <| + transc := Fun Atn (Var "x"); + poly := [ + -6809284315197713 * inv ( 2 pow 84 ); + 8979859070570549 * inv ( 2 pow 53 ); + 2502429001398681 * inv ( 2 pow 78 ); + -2531269759855903 * inv ( 2 pow 53 ); + ]; + eps := 77569196655847480248172279652945299732867702355 * inv (2 pow 167 ); + iv := [ ("x", + ( -1 * inv (2 pow 1 ), + 1 * inv (2 pow 1 )))]; +|> +End + +Theorem atn_cml_code_corr = implement cos_example_def "atn" + +val _ = export_theory(); diff --git a/floatingPoint/libmGen/cosExampleScript.sml b/floatingPoint/libmGen/cosExampleScript.sml new file mode 100644 index 0000000000..630ea8d450 --- /dev/null +++ b/floatingPoint/libmGen/cosExampleScript.sml @@ -0,0 +1,10 @@ +(* + Example libm function generated from cosine certificate of Dandelion +*) +open libmLib cosDeg3Theory; + +val _ = new_theory "cosExample"; + +Theorem cos_cml_code_corr = implement cos_example_def "cos" + +val _ = export_theory(); diff --git a/floatingPoint/libmGen/expExampleScript.sml b/floatingPoint/libmGen/expExampleScript.sml new file mode 100644 index 0000000000..fc0d6ca317 --- /dev/null +++ b/floatingPoint/libmGen/expExampleScript.sml @@ -0,0 +1,29 @@ +(* + Example libm function generated from cosine certificate of Dandelion +*) +open libmLib; + +val _ = new_theory "expExample"; + +Definition exp_example_def: + exp_example = + <| + transc := Bop Add (Fun Exp (Bop Mul (Var "x") (Cst (1/2:real)))) (Fun Cos (Bop Mul (Var "x") (Cst (1/2:real)))); +poly := [ + 9007199045267507 * inv ( 2 pow 52 ); + 4503607326537297 * inv ( 2 pow 53 ); + -3241616109733325 * inv ( 2 pow 69 ); + 375588665660545 * inv ( 2 pow 54 ); + 5979080956143783 * inv ( 2 pow 60 ); + 5038332231908613 * inv ( 2 pow 64 ); + ]; + eps := 27896958177787588423236394485375286824270176601341 * inv (2 pow 192 ); + iv := [ ("x", + ( 37414441915671114706014331717536845303191873100185 * inv (2 pow 168 ), + 1 * inv (2 pow 0 )))]; + |> +End + +Theorem cos_cml_code_corr = implement exp_example_def "exp_add_cos" + +val _ = export_theory(); diff --git a/floatingPoint/libmGen/libmLib.sml b/floatingPoint/libmGen/libmLib.sml new file mode 100644 index 0000000000..dd9da2c60b --- /dev/null +++ b/floatingPoint/libmGen/libmLib.sml @@ -0,0 +1,178 @@ +(* + Implementation of automatic generation of libm functions +*) +structure libmLib = +struct + + (* Dandelion *) + open realZeroLib floverConnTheory; + (* CakeML & FloVer *) + open FloVerToCakeMLTheory FloVerToCakeMLProofsTheory expressionsLib + basisProgTheory basis_ffiTheory cfHeapsBaseTheory basis cfTacticsLib + ml_translatorLib cfSupportTheory; + open libmTheory; + open binary_ieeeLib; + + val _ = translation_extends "basisProg"; + + exception libmGenException of string; + + val approxSteps = “16:num”; (** TODO: make this a parameter ? **) + + val zero_eq = GSYM $ Q.SPEC ‘1’ REAL_DIV_LZERO + + val _ = Globals.max_print_depth := 20; + + (** For debugging the implement function + val certDef = cosDeg3Theory.cos_example_def + val certValid = cosDeg3Theory.err_sound_thm + **) + + (** implement produce CakeML code for elementary functions Input: f, a math function to be implemented in CakeML with an error bound + iv, an interval constraint for the function inputs + Output: a CF theorem relating the code for the mathematical function to its + real equivalent + **) + local + fun REV_MATCH_MP th1 th2 = MATCH_MP th2 th1 + in + fun implement (certDef:thm) cmlFname :thm = let + val certValid = validateCert certDef approxSteps + val thePoly = certValid |> SPEC_ALL |> concl |> dest_imp |> snd + |> rator |> rand |> rand |> rand |> rator |> rand + val theTransc = EVAL “^(certDef |> rhs o concl).transc” + val thePoly_nonzero = EVAL “^thePoly <> []” |> SIMP_RULE std_ss [] + val thePoly_getThm = EVAL “^(certDef |> rhs o concl).poly = ^thePoly” |> SIMP_RULE std_ss [] + val floverExpThm = EVAL “poly2FloVer ^thePoly” |> ONCE_REWRITE_RULE [zero_eq] + val floverExpTm = floverExpThm |> rhs o concl + val floverFloatExpThm = EVAL “toFloVerFloatExp ^floverExpTm” |> ONCE_REWRITE_RULE [zero_eq] + val floverFloatExpTm = floverFloatExpThm |> rhs o concl + val floverExpRatEqThm = EVAL “poly2FloVer ^thePoly = toREval ^floverFloatExpTm” + |> SIMP_RULE std_ss [] + val floverToCmlFloatThm = EVAL “toCmlFloatProg ^floverFloatExpTm” + |> SIMP_RULE std_ss [machine_ieeeTheory.float_to_fp64_def] + |> REWRITE_RULE [binary_ieeeTheory.real_to_float_def, + binary_ieeeTheory.float_round_def] + |> CONV_RULE $ RHS_CONV EVAL + val is64BitEvalThm = EVAL “is64BitEval ^floverFloatExpTm” |> SIMP_RULE std_ss [] + val noDowncastThm = EVAL “noDowncast ^floverFloatExpTm” |> SIMP_RULE std_ss [] + val theEnv = EVAL “FloverMapTree_insert (Var 0) M64 FloverMapTree_empty” |> rhs o concl + val is64BitEnvThm = EVAL “is64BitEnv ^theEnv” |> SIMP_RULE std_ss [CaseEq"expr"] + val P = EVAL “getPrecondFromCert ^(certDef |> rhs o concl)” + val P_zero = EVAL “^(P |> rhs o concl) 0” + val usedVarsThm = EVAL “usedVars ^floverFloatExpTm” + val ivbounds = + EVAL “inferIntervalbounds ^floverFloatExpTm ^(P |> rhs o concl) FloverMapTree_empty” + |> rhs o concl |> optionSyntax.dest_some + val typeMap = + EVAL “case getValidMap ^theEnv ^floverFloatExpTm FloverMapTree_empty of Succes G => G” + |> rhs o concl + val errbounds = + EVAL “inferErrorbound ^floverFloatExpTm ^typeMap ^ivbounds FloverMapTree_empty” + |> rhs o concl |> optionSyntax.dest_some + val cc_valid = EVAL “CertificateChecker ^floverFloatExpTm ^errbounds ^(P |> rhs o concl) ^theEnv” + val find_thm = EVAL “FloverMapTree_find ^floverFloatExpTm ^errbounds” + val floverToCmlFloatTm = floverToCmlFloatThm |> rhs o concl |> optionSyntax.dest_some + val theFunction = + (** FIXME: inject name?? **) + “[Dlet unknown_loc (Pvar ^(stringSyntax.fromMLstring cmlFname)) (Fun "x0" + ^floverToCmlFloatTm)]” + val theEnv_before = get_ml_prog_state() + |> ml_progLib.clean_state + |> ml_progLib.remove_snocs + |> ml_progLib.get_env + val _ = append_prog theFunction; + val st = get_ml_prog_state(); + val theFunction_v_def = DB.find_in (cmlFname ^ "_v_def") $ DB.thy (Theory.current_theory())|> hd |> #2 |> #1 + val do_opapp_thm = “do_opapp [^(fetch_v cmlFname st); v]” + |> SIMP_CONV std_ss [theFunction_v_def] + |> CONV_RULE $ RHS_CONV EVAL + val theEnv_term = theEnv_before |> SIMP_CONV std_ss [ml_progTheory.merge_env_def, namespaceTheory.nsAppend_def, nsBind_nsAppend] |> rhs o concl + val mkEnv_def = Define ‘mkEnv v = ^theEnv_term with v := nsAppend (Bind [("x0", v)] []) ^(theEnv_term).v’ + val approxErr_def = Define ‘approxErr = ^(certValid |> SPEC_ALL |> concl |> rand |> rand)’ + val roundoffErr_def = Define ‘roundoffErr = ^(find_thm |> rhs o concl |> optionSyntax.dest_some |> dest_pair |> snd)’ + val fullErr_tm = EVAL“approxErr + roundoffErr”|> rhs o concl + val fullErr_def = Define ‘fullErr = ^fullErr_tm’ + val theCMLprog_def = Define ‘theCMLprog = ^floverToCmlFloatTm’ + in + MATCH_MP (REWRITE_RULE [GSYM AND_IMP_INTRO] theFunSpec_thm_general) P + |> REV_MATCH_MP floverExpRatEqThm + |> REV_MATCH_MP thePoly_nonzero + |> REV_MATCH_MP thePoly_getThm + |> REV_MATCH_MP P_zero + |> REV_MATCH_MP is64BitEvalThm + |> REV_MATCH_MP noDowncastThm + |> REV_MATCH_MP is64BitEnvThm + |> REV_MATCH_MP usedVarsThm + |> REV_MATCH_MP cc_valid + |> REWRITE_RULE [theTransc] + |> REV_MATCH_MP $ SIMP_RULE std_ss [GSYM AND_IMP_INTRO] certValid + |> REV_MATCH_MP find_thm + |> REV_MATCH_MP $ GSYM floverToCmlFloatThm + |> REV_MATCH_MP do_opapp_thm + |> Q.SPEC ‘^theEnv_before’ + |> SIMP_RULE std_ss [ml_progTheory.merge_env_def, namespaceTheory.nsAppend_def, nsBind_nsAppend] + |> CONV_RULE $ RATOR_CONV EVAL + |> SIMP_RULE std_ss [] + |> CONV_RULE $ RATOR_CONV EVAL + |> SIMP_RULE std_ss [GSYM mkEnv_def, GSYM approxErr_def, GSYM roundoffErr_def, GSYM theCMLprog_def] + end + end; + +end + +(** UNUSED + + local + fun removeDots s = + String.translate (fn c => if c = #"." then "" else Char.toString c) s + in + (** + Input: f:mf, the function to approximate; + iv:string * string, the input constraints as lower and upper bound in + dot notation i.e. "0.1" + **) + fun mkSollyaCall (f:mf) (iv:string * string) = let + val sollyaInp = + "oldDisplay=display;\n" ^ + "display = powers!;\n" ^ + "approxPrec = 23;\n" ^ (* TODO: Make parameter? *) + "deg = 3;\n" ^ (* TODO: Same here? *) + "f = " ^ (mfToSollya f) ^ "(x);\n"^ + "dom = ["^fst(iv)^"; "^snd(iv)^"];\n" ^ + "p = fpminimax(f, deg, [|approxPrec,approxPrec...|], dom, absolute);\n" ^ + "derivativeZeros = findzeros(diff(p-f),dom);\n" ^ + "maximum=0;\n" ^ + "for t in derivativeZeros do {\n" ^ + " r = evaluate(abs(p-f), t);\n" ^ + " if sup(r) > maximum then { maximum=sup(r); argmaximum=t; };\n" ^ + " if (evaluate(diff(p-f),inf(t)) * evaluate (diff(p-f),sup(t)) <= 0 ) then {\n" ^ + " print (\"Ok zero:\");\n" ^ + " print (\" (\", mantissa (inf(t)), \" * inv (2 pow\", -exponent(inf(t)), \"),\");\n" ^ + " print (\" \", mantissa (sup(t)), \" * inv (2 pow\", -exponent(sup(t)), \"));\");\n" ^ + " };\n" ^ + "};\n" + val outputFile = "/tmp/"^(mfToSollya f)^ removeDots (fst iv) ^ removeDots (snd iv) ^ ".sollya" + val fd = TextIO.openOut outputFile + val _ = (TextIO.output(fd, sollyaInp); TextIO.closeOut fd); + val _ = + +print("<|"); +print(" poly := ["); +for i from 0 to degree(p) do{ + coeff_p = coeff(p, i); + print(" ", mantissa (coeff_p), " * inv ( 2 pow ", -exponent(coeff_p), ");"); +}; +print (" ];"); +print(" eps := ", mantissa(maximum), " * inv (2 pow", -exponent(maximum), ");"); +print (" iv := [ (\"x\","); +print (" (", mantissa (inf(dom)), " * inv (2 pow", -exponent(inf(dom)), "),"); +print (" ", mantissa (sup(dom)), " * inv (2 pow", -exponent(sup(dom)), ")))];"); +print("|>"); + val + + (** TODO: Implement; + returns a Sollya certificate for the math function to be checked by + Dandelion as well as guesses for the zeros **) + fun getApproxForFun (f:mf) iv :(term*term) = (“T”,“T”); +**) diff --git a/floatingPoint/libmGen/libmScript.sml b/floatingPoint/libmGen/libmScript.sml new file mode 100644 index 0000000000..4767b0f770 --- /dev/null +++ b/floatingPoint/libmGen/libmScript.sml @@ -0,0 +1,108 @@ +(* + Supporting proofs for automation +*) +(* Dandelion *) +open realZeroLib floverConnTheory; +(* CakeML & FloVer *) +open pureExpsTheory FloVerToCakeMLTheory FloVerToCakeMLProofsTheory + expressionsLib basisProgTheory basis_ffiTheory cfHeapsBaseTheory basis + cfTacticsLib ml_translatorLib cfSupportTheory; + +val _ = new_theory "libm"; + +Theorem nsBind_nsAppend: + nsBind x v env = nsAppend (Bind [(x,v)] []) env +Proof + Cases_on ‘env’ >> gs[namespaceTheory.nsAppend_def, namespaceTheory.nsBind_def] +QED + +Definition value_has_err_of_def: + value_has_err_of f x (rv:v) err = + case rv of + |FP_WordTree fp => + (realax$abs + (optionGet (interp f [("x", x)]) - (fp64_to_real (compress_word fp))) + ≤ err) + | _ => F +End + +Theorem theFunSpec_thm_general: + ∀ cert lo hi exp expRat fun_v prog progReal env env2 Gamma P typeAnn A iv + err ply delta v. + getPrecondFromCert cert = P ∧ + poly2FloVer ply = toREval exp ∧ + ply ≠ [] ∧ + cert.poly = ply ∧ + P 0 = (lo,hi) ∧ + is64BitEval exp ∧ + noDowncast exp ∧ + is64BitEnv Gamma ∧ + usedVars exp = LS () ∧ (* usedVars exp = { 0 } *) + CertificateChecker exp A P Gamma = SOME typeAnn ∧ + (∀ x. lo ≤ x ∧ x ≤ hi ⇒ + realax$abs (optionGet (interp (cert.transc) [("x", x)]) - evalPoly ply x) ≤ delta) ∧ + FloverMapTree_find exp A = SOME (iv, err) ∧ + SOME prog = toCmlFloatProg exp ∧ + do_opapp [fun_v; v] = + SOME (env2, prog) ∧ + env2 = env with v := nsAppend (Bind [("x0", v)] []) env.v ∧ + isPureExpList [prog] ⇒ + ∀ fp (st:unit semanticPrimitives$state). + lo <= fp64_to_real (compress_word (Fp_const fp)) /\ + fp64_to_real (compress_word (Fp_const fp)) <= hi /\ + fp64_isFinite (compress_word (Fp_const fp)) /\ + DOUBLE (Fp_const fp) v ⇒ + app (p:unit ffi_proj) fun_v [v] (emp) + (POSTv rv. &(value_has_err_of (cert.transc) (fp64_to_real fp) rv (delta + err))) +Proof + rpt strip_tac + >> qpat_x_assum ‘_ = env with v := nsAppend _ _’ mp_tac + >> qmatch_goalsub_abbrev_tac ‘nsAppend flEnv _’ >> strip_tac + >> drule $ INST_TYPE [“:'ffi”|->“:unit”] FloVer_CakeML_sound_error + >> rpt $ disch_then drule + >> disch_then $ qspec_then ‘flEnv’ mp_tac >> impl_tac + >- ( + unabbrev_all_tac >> gs[usedVars_P_sound_def] + >> gvs[namespaceTheory.nsLookup_def, DOUBLE_def]) + >> disch_then $ qspec_then ‘env’ strip_assume_tac + >> gs[app_def, app_basic_def] >> rpt strip_tac + >> Q.REFINE_EXISTS_TAC ‘Val fpN’ + >> simp[evaluate_to_heap_def, evaluate_ck_def] + >> gs[emp_def, value_has_err_of_def] + >> first_x_assum $ + qspec_then ‘(st' with fp_state := st'.fp_state with + <| real_sem := F; canOpt := FPScope Opt |>)’ + strip_assume_tac + >> first_x_assum $ + mp_then Any mp_tac + (INST_TYPE [“:'a”|->“:unit”, “:'b”|->“:unit”] isPureExpList_swap_state) + >> gs[] + >> strip_tac + >> qexists_tac ‘EMPTY’ >> qexists_tac ‘EMPTY’ + >> gs[SPLIT_def, SPLIT3_def, cond_def, DOUBLE_def] + >> qmatch_goalsub_abbrev_tac ‘realax$abs ( f_eval - double_eval)’ + >> ‘f_eval - double_eval = + (f_eval - evalPoly ply (fp64_to_real fp)) + (evalPoly ply (fp64_to_real fp) - double_eval)’ + by REAL_ARITH_TAC + >> pop_assum $ once_rewrite_tac o single + >> irule REAL_LE_TRANS + >> irule_at Any REAL_ABS_TRIANGLE + >> irule REAL_LE_ADD2 >> conj_tac + >- ( + unabbrev_all_tac + >> first_x_assum irule >> gs[fpSemTheory.compress_word_def]) + >> ‘evalPoly ply (fp64_to_real fp) = r’ suffices_by gs[] + >> rewrite_tac[evalPoly_Flover_eval_bisim] + >> gs[] + >> ‘toREnv (toFloVerEnv flEnv exp') = λ v. if v = 0 then SOME (fp64_to_real fp) else NONE’ + by ( + unabbrev_all_tac + >> gs[FUN_EQ_THM, IEEE_connectionTheory.toREnv_def, toFloVerEnv_def] + >> rpt strip_tac + >> Cases_on ‘v' = 0’ >> gs[] + >> gs[lookup_def, namespaceTheory.nsLookup_def, + machine_ieeeTheory.fp64_to_real_def, fpSemTheory.compress_word_def]) + >> gs[] +QED + +val _ = export_theory(); diff --git a/floatingPoint/libmGen/readmePrefix b/floatingPoint/libmGen/readmePrefix new file mode 100644 index 0000000000..99b768b0e7 --- /dev/null +++ b/floatingPoint/libmGen/readmePrefix @@ -0,0 +1,3 @@ +A libm-generator for CakeML that uses Dandelion and FloVer from `tools` +to prove a specification that relates CakeML code to the real-valued elementary +function. diff --git a/floatingPoint/libmGen/sinExampleScript.sml b/floatingPoint/libmGen/sinExampleScript.sml new file mode 100644 index 0000000000..dc7dbcae15 --- /dev/null +++ b/floatingPoint/libmGen/sinExampleScript.sml @@ -0,0 +1,10 @@ +(* + Example libm function generated from sine certificate of Dandelion +*) +open libmLib sinDeg3Theory; + +val _ = new_theory "sinExample"; + +Theorem sin_cml_code_corr = implement sin_example_def "sin" + +val _ = export_theory(); diff --git a/floatingPoint/tools/README.md b/floatingPoint/tools/README.md new file mode 100644 index 0000000000..96776ce5bb --- /dev/null +++ b/floatingPoint/tools/README.md @@ -0,0 +1,3 @@ +# Tools used in CakeML +This directory contains tools used by CakeML's floating-point arithmetic +implementation. diff --git a/floatingPoint/tools/dandelion/.hol_preexec b/floatingPoint/tools/dandelion/.hol_preexec new file mode 100644 index 0000000000..b58782322c --- /dev/null +++ b/floatingPoint/tools/dandelion/.hol_preexec @@ -0,0 +1,11 @@ +tar -xf sollya-8.0.tar.gz sollya-8.0 &&\ +cd sollya-8.0 &&\ +./configure &&\ +make &&\ +rm -rf ./build-aux doc m4 tests-lib tests-tool &&\ +rm -rf ./*.c ./*.h &&\ +CURRDIR=$(pwd) &&\ +FULLPATH="$CURRDIR/sollya" +cd ../ + +sed -i "s,FILLED_IN_BY_HOLPREEXEC,$FULLPATH,g" realZeroLib.sml diff --git a/floatingPoint/tools/dandelion/Holmakefile b/floatingPoint/tools/dandelion/Holmakefile new file mode 100644 index 0000000000..772f7a08f9 --- /dev/null +++ b/floatingPoint/tools/dandelion/Holmakefile @@ -0,0 +1,13 @@ +INCLUDES = $(HOLDIR)/examples/algebra/polynomial\ + $(CAKEMLDIR)/floatingPoint/tools/flover\ + $(CAKEMLDIR)/floatingPoint/tools/flover/semantics + +all: $(DEFAULT_TARGETS) README.md +.PHONY: all + +README_SOURCES = $(wildcard *Script.sml) $(wildcard *Lib.sml) $(wildcard *Syntax.sml) +DIRS = $(wildcard */) +README.md: $(CAKEMLDIR)/developers/readme_gen readmePrefix $(README_SOURCES) + $(CAKEMLDIR)/developers/readme_gen $(README_SOURCES) + +EXTRA_CLEANS = sollya-8.0/* diff --git a/floatingPoint/tools/dandelion/README.md b/floatingPoint/tools/dandelion/README.md new file mode 100644 index 0000000000..b15f7fca85 --- /dev/null +++ b/floatingPoint/tools/dandelion/README.md @@ -0,0 +1,147 @@ +# Dandelion + +A certificate checker for approximations of elementary functions. + +## Building Dandelion + +Dandelion relies on a copy of sollya (sollya.org). Therefore it is +necessary to run `Holmake` in this directory to execute the code +in `.hol_preexec`. + +## Key theorems and definitions relating to the original ITP'22 paper + +The first phase is defined across the files `transcApproxSemScript.sml` and +`approxPolyScript.sml`. The first file defines the overall approximation +function `approxAsPoly` and gives its soundness proof, and +`approxPolyScript.sml` defines the low-level approximation function for +approximating a single elementary function with a single polynomial and proves +soundness of this function. + +Theorem 4 (First Phase Soundness) from section 3 is proven in file +`transcApproxSemScript.sml` as `approxTransc_sound`. +Variants of Theorem 5 are proven for the supported elementary function in file +`mcLaurinApproxScript.sml` if they are not provided by HOL4. +Variants of Theorem 6 are proven for the supported elementary functions in file +`approxPolyScript.sml`. + +The second phase is implemented and proven sound in the file +`checkerScript.sml`. +It relies on the implementation of computable Sturm sequences in +`sturmComputeScript.sml` and computable polynomial division in +`euclidDivScript.sml`. + +Theorem 7 (Second Phase Soundness) from section 4 is proven in file +`checkerScript.sml` as the combination of `numZeros_sound`, +`validBounds_is_valid`, and `validateZerosLeqErr_sound`. + +Theorem 8 was ported from Harrison's HOL-Light proofs in file `drangScript.sml` +and is called `BOUND_THEOREM_INEXACT`. + +Theorem 9 (Dandelion soundness) is called `checker_soundness` in file +`checkerScript.sml`. + +The extracted binary is created in the directory `binary`. +File `translateScript.sml` sets up the CakeML translation of the definitions of +Dandelion, file `certParserScript.sml` defines our (unverified) parser and +lexer, file `sturmMainCakeScript.sml` proves the CakeML specification for the +binary, and file `sturmMainCakeCompileScript.sml` compiles the binary for the +second phase by running the CakeML compiler in-logic on the translated +definitions. + +[approxCompErrScript.sml](approxCompErrScript.sml): +Theorems about how to compose errors from truncated Taylor series +for each supported elementary function + +[approxPolyScript.sml](approxPolyScript.sml): +Function that computes a polynomial approximation for a single elementary +function on a fixed interval, and its soundness proof. +Function approxPoly is reused in transcApproxSemScript.sml to build the overall +function implementing the first phase of Dandelion + +[checkerDefsScript.sml](checkerDefsScript.sml): +Basic definitions used by Dandelion + +[checkerScript.sml](checkerScript.sml): +Define high-level functions used by Dandelion and prove their +soundness by composing soundness proofs from the included files + +[cosDeg3Script.sml](cosDeg3Script.sml): +Simple cosine of degree 3 + +[drangScript.sml](drangScript.sml): +Proofs ported about extrema of real-valued, univariate functions, +ported from the work by Harrison + +[euclidDivScript.sml](euclidDivScript.sml): +Computable version of polynomial division and a correctness proof. +Inspired by the implementation in Isabelle/HOL +isabelle.in.tum.de/library/HOL/HOL-Computational_Algebra/Polynomial.html +used to implement a computable version of Sturm sequences + +[floverConnScript.sml](floverConnScript.sml): +Connection to FloVer roundoff error analyzer, currently unused + +[mcLaurinApproxScript.sml](mcLaurinApproxScript.sml): +Proofs of McLaurin series for the supported elementary functions +described in transcLang file + +[moreRealScript.sml](moreRealScript.sml): +small theorems extending HOL4's realTheory +used throughout the development + +[pointCheckerProofsScript.sml](pointCheckerProofsScript.sml): +Soundness theorem of the point-wise equivalence checker +Currently unused + +[pointCheckerScript.sml](pointCheckerScript.sml): +A simple checker for polynomial evaluation +Part one of the soundness proof requires showing that the approximated +polynomial agrees with what Remez thought the trancendental function behaves +like on the set of points Ω + +[realPolyProofsScript.sml](realPolyProofsScript.sml): +Some simple properties of polynomials on reals + +[realPolyScript.sml](realPolyScript.sml): +Definition of datatype for real-valued polynomials + +[realZeroLib.sml](realZeroLib.sml): +Library implementing the automatic computations +done by Dandelion + +[renameScript.sml](renameScript.sml): +renaming theory to unify naming of theorems + +[sinDeg3Script.sml](sinDeg3Script.sml): +Simple approximation of sine of degree 3 + +[sollya-8.0](sollya-8.0): +Dependency to generate unverified guesses + +[sturmComputeScript.sml](sturmComputeScript.sml): +Define a computable version of the sturm sequence and +prove its equivalence with the non-computable version +of John Harrison + +[sturmScript.sml](sturmScript.sml): +Proof of Sturm's theorem, ported from Harrison material + +[transcApproxSemScript.sml](transcApproxSemScript.sml): +Define an "approximating" semantics on the elementary functions +of Dandelion. The function approxTransc corresponds to the +function "approxAsPoly" in the paper + +[transcIntvSemScript.sml](transcIntvSemScript.sml): +Define an interval semantics on the elementary functions +of Dandelion. The function borrows the definitions and soundness +proof of basic arithmetic from FloVer + +[transcLangScript.sml](transcLangScript.sml): +Define a simple "language" for describing elementary +functions. For now we only allow combinations, i.e. +exp (sin (cos ...) but no additional operators like +,-,*,/ + +[transcReflectScript.sml](transcReflectScript.sml): +Simple reflection function translating elements of the deeply +embedded transc datatype into the polynomials defined in +realPolyScript.sml diff --git a/floatingPoint/tools/dandelion/approxCompErrScript.sml b/floatingPoint/tools/dandelion/approxCompErrScript.sml new file mode 100644 index 0000000000..91b42cf4b8 --- /dev/null +++ b/floatingPoint/tools/dandelion/approxCompErrScript.sml @@ -0,0 +1,180 @@ +(** + Theorems about how to compose errors from truncated Taylor series + for each supported elementary function +**) +open IntervalArithTheory ErrorValidationTheory sqrtApproxTheory; +open moreRealTheory mcLaurinApproxTheory realPolyTheory realPolyProofsTheory + transcLangTheory approxPolyTheory transcIntvSemTheory; +open preambleDandelion; + +val _ = new_theory "approxCompErr"; + +Theorem MCLAURIN_EXP_COMPOSITE_ERR: + ∀ x y err lb ub errExpUb errExpY p. + 0 ≤ err ∧ + err ≤ inv 2 ∧ (* the error is reasonably small *) + abs (x - y) ≤ err ∧ + lb ≤ x ∧ x ≤ ub ∧ + abs (exp ub - evalPoly p ub) ≤ errExpUb ⇒ + abs (exp y - evalPoly p y) ≤ errExpY ⇒ + abs (exp x - evalPoly p y) ≤ + errExpY + (* Exp error *) + (evalPoly p ub + errExpUb) + * (2 * err) (* propagated error from f *) +Proof + rpt strip_tac >> drule MCLAURIN_EXP_COMPOSITE + >> disch_then $ drule_then assume_tac + >> transitivity_for ‘abs (exp x - exp y) + abs (exp y - evalPoly p y)’ + >> conj_tac + >- ( + transitivity_for ‘abs (exp x - exp y + (exp y - evalPoly p y))’ + >> conj_tac >> real_tac) + >> ‘&FACT n ≠ 0’ by (unabbrev_all_tac >> rpt $ pop_assum kall_tac >> Induct_on ‘n’ >> gs[FACT]) + >> ‘abs (inv (&FACT n)) = inv (&FACT n)’ + by (gs[abs]) + >> qmatch_goalsub_abbrev_tac ‘abs expProp + abs expNew’ + >> real_rw ‘abs expProp + abs expNew = abs expNew + abs expProp’ + >> irule REAL_LE_ADD2 >> conj_tac + (* New error *) + >- ( unabbrev_all_tac >> gs[]) + >> transitivity_for ‘exp x * (exp err - 1)’ >> gs[] + >> transitivity_for ‘exp x * (1 + 2 * err - 1)’ >> conj_tac + >- ( + irule REAL_LE_LMUL_IMP >> gs[EXP_POS_LE, real_sub] + >> irule REAL_EXP_BOUND_LEMMA >> gs[]) + >> real_rw ‘1 + 2 * err - 1 = 2 * err’ + >> real_rw ‘exp x * (2 * err) = 2 * (err * exp x)’ + >> ntac 2 $ (irule REAL_LE_LMUL_IMP >> gs[]) + >> transitivity_for ‘exp ub’ >> gs[EXP_MONO_LE] + >> real_tac +QED + +Theorem MCLAURIN_SIN_COMPOSITE_ERR: + ∀ x y err iv steps polySin errSin polyCos errCos p errSinY. + 0 ≤ err ∧ err ≤ inv 2 ∧ + abs (x - y) ≤ err ∧ + approxPolySideCond steps ∧ + approxPoly Sin (0, err) steps = SOME (polySin, errSin) ∧ + approxPoly Cos (0, err) steps = SOME (polyCos, errCos) ∧ + abs (sin y - evalPoly p y) ≤ errSinY ⇒ + abs (sin x - evalPoly p y) ≤ + errSinY + + (abs (evalPoly polyCos err - errCos - 1) + evalPoly polySin err + errSin) +Proof + rpt strip_tac >> drule MCLAURIN_SIN_COMPOSITE + >> ‘err ≤ pi / 2’ + by (irule REAL_LE_TRANS >> qexists_tac ‘inv 2’ >> gs[inv2_le_pi2]) + >> disch_then $ drule_then $ drule_then assume_tac + >> real_rw ‘sin x - evalPoly p y = (sin y - evalPoly p y) + (sin x - sin y)’ + >> transitivity_for ‘abs (sin y - evalPoly p y) + abs (sin x - sin y)’ + >> conj_tac >- gs[REAL_ABS_TRIANGLE] + >> irule REAL_LE_ADD2 >> conj_tac >- gs[] + >> transitivity_for ‘abs (cos err - 1) + sin err’ + >> conj_tac >- gs[] + >> rewrite_tac [GSYM REAL_ADD_ASSOC] + >> drule approxPoly_soundness + >> disch_then (fn th => + qspec_then ‘Sin’ mp_tac th + >> qspec_then ‘Cos’ mp_tac th) + >> disch_then $ drule_then $ qspec_then ‘err’ mp_tac + >> impl_tac >- gs[] + >> strip_tac + >> disch_then $ drule_then $ qspec_then ‘err’ mp_tac + >> impl_tac >- gs[] + >> strip_tac >> gs[getFun_def] + >> irule REAL_LE_ADD2 >> reverse conj_tac + >- real_tac + >> ‘evalPoly polyCos err - errCos ≤ cos err’ by real_tac + >> ‘cos err ≤ 1’ by (gs[COS_BOUNDS]) + >> ‘cos err - 1 ≤ 0’ by real_tac + >> ‘evalPoly polyCos err - errCos - 1 ≤ 0’ by real_tac + >> rewrite_tac [GSYM abs_alt_abs] + >> gs[abs_alt_def, real_sub] +QED + +Theorem MCLAURIN_COS_COMPOSITE_ERR: + ∀ x y err iv steps polySin errSin polyCos errCos p errCosY. + 0 ≤ err ∧ err ≤ inv 2 ∧ + abs (x - y) ≤ err ∧ + approxPolySideCond steps ∧ + approxPoly Sin (0, err) steps = SOME (polySin, errSin) ∧ + approxPoly Cos (0, err) steps = SOME (polyCos, errCos) ∧ + abs (cos y - evalPoly p y) ≤ errCosY ⇒ + abs (cos x - evalPoly p y) ≤ + errCosY + + (abs (evalPoly polyCos err - errCos - 1) + evalPoly polySin err + errSin) +Proof + rpt strip_tac >> drule MCLAURIN_COS_COMPOSITE + >> ‘err ≤ pi / 2’ + by (irule REAL_LE_TRANS >> qexists_tac ‘inv 2’ >> gs[inv2_le_pi2]) + >> disch_then $ drule_then $ drule_then assume_tac + >> real_rw ‘cos x - evalPoly p y = (cos y - evalPoly p y) + (cos x - cos y)’ + >> transitivity_for ‘abs (cos y - evalPoly p y) + abs (cos x - cos y)’ + >> conj_tac >- gs[REAL_ABS_TRIANGLE] + >> irule REAL_LE_ADD2 >> conj_tac >- gs[] + >> transitivity_for ‘abs (cos err - 1) + sin err’ + >> conj_tac >- gs[] + >> rewrite_tac [GSYM REAL_ADD_ASSOC] + >> drule approxPoly_soundness + >> disch_then (fn th => + qspec_then ‘Sin’ mp_tac th + >> qspec_then ‘Cos’ mp_tac th) + >> disch_then $ drule_then $ qspec_then ‘err’ mp_tac + >> impl_tac >- gs[] + >> strip_tac + >> disch_then $ drule_then $ qspec_then ‘err’ mp_tac + >> impl_tac >- gs[] + >> strip_tac >> gs[getFun_def] + >> irule REAL_LE_ADD2 >> reverse conj_tac + >- real_tac + >> ‘evalPoly polyCos err - errCos ≤ cos err’ by real_tac + >> ‘cos err ≤ 1’ by (gs[COS_BOUNDS]) + >> ‘cos err - 1 ≤ 0’ by real_tac + >> ‘evalPoly polyCos err - errCos - 1 ≤ 0’ by real_tac + >> rewrite_tac [GSYM abs_alt_abs] + >> gs[abs_alt_def, real_sub] +QED + +Theorem MCLAURIN_LN_COMPOSITE_ERR: + ∀ x y z err iv steps polyLn errLn p errLnY. + 0 ≤ err ∧ 0 < x ∧ 0 < y ∧ 0 < z ∧ + abs (x - y) ≤ err ∧ z ≤ min x y ∧ + approxPolySideCond steps ∧ + approxPoly Log (1 + err/z, 1 + err/z) steps = SOME (polyLn, errLn) ⇒ + abs (ln y - evalPoly p y) ≤ errLnY ⇒ + abs (ln x - evalPoly p y) ≤ + errLnY + (evalPoly polyLn (1 + err/z) + errLn) +Proof + rpt strip_tac >> drule MCLAURIN_LN_COMPOSITE + >> disch_then $ qspecl_then [‘x’, ‘y’] mp_tac + >> impl_tac >- gs[] + >> strip_tac + >> real_rw ‘ln x - evalPoly p y = (ln y - evalPoly p y) + (ln x - ln y)’ + >> transitivity_for ‘abs (ln y - evalPoly p y) + abs (ln x - ln y)’ + >> conj_tac >- gs[REAL_ABS_TRIANGLE] + >> irule REAL_LE_ADD2 >> conj_tac >- gs[] + >> transitivity_for ‘abs (ln (1 + err / min x y))’ + >> conj_tac >- gs[] + >> ‘0 < min x y ’ by (gs[min_def] >> cond_cases_tac >> gs[]) + >> ‘0 ≤ err / min x y’ by (gs[nonzerop_def] >> cond_cases_tac >> gs[]) + >> ‘1 ≤ 1 + err / min x y’ by real_tac + >> ‘0 ≤ ln (1 + err / min x y)’ by gs[LN_POS] + >> gs[abs] + >> irule REAL_LE_TRANS + >> qexists_tac ‘ln (1 + err / z)’ >> conj_tac + >- ( + ‘0 ≤ err / z’ by (gs[nonzerop_def] >> cond_cases_tac >> gs[]) + >> ‘0 < 1 + err / z’ by real_tac + >> Cases_on ‘err = 0’ >> gs[LN_1] + >> ‘0 < err / min x y’ by (gs[nonzerop_def] >> cond_cases_tac >> gs[] >> real_tac) + >> ‘0 < 1 + err / min x y’ by real_tac + >> gs[LN_MONO_LE]) + >> drule approxPoly_soundness + >> disch_then drule + >> disch_then $ qspec_then ‘1 + err / z’ mp_tac >> impl_tac >- gs[] + >> gs[getFun_def] + >> disch_then $ mp_then Any assume_tac ERR_ABS_SIMP + >> gs[] +QED + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/approxPolyScript.sml b/floatingPoint/tools/dandelion/approxPolyScript.sml new file mode 100644 index 0000000000..0ab2b0d29a --- /dev/null +++ b/floatingPoint/tools/dandelion/approxPolyScript.sml @@ -0,0 +1,1061 @@ +(** + Function that computes a polynomial approximation for a single elementary + function on a fixed interval, and its soundness proof. + Function approxPoly is reused in transcApproxSemScript.sml to build the overall + function implementing the first phase of Dandelion +**) +open realTheory realLib RealArith transcTheory; +open realPolyTheory realPolyProofsTheory mcLaurinApproxTheory transcLangTheory; +open preambleDandelion; + +val _ = new_theory "approxPoly"; + +(** functions computing the McLaurin series for transcendental functions **) +Definition expPoly_def: + expPoly 0 = [] ∧ (* x pow 0 * inv FACT 0 *) + expPoly (SUC n) = (expPoly n) ++ [inv (&FACT n)] +End + +Definition cosPoly_def: + cosPoly 0 = [] ∧ + cosPoly (SUC n) = + if (EVEN n) then + cosPoly n ++ [-1 pow (n DIV 2) * inv (&FACT n)] + else cosPoly n ++ [0] +End + +Definition sinPoly_def: + sinPoly 0 = [] ∧ + sinPoly (SUC n) = + if (EVEN n) then sinPoly n ++ [0] + else sinPoly n ++ [-1 pow ((n - 1) DIV 2) * inv (&FACT n)] +End + +Definition sqrtPoly_def: + sqrtPoly 0 = [] ∧ + sqrtPoly (SUC n) = sqrtPoly n ++ + [ -1 pow (n - 1) * &FACT (2 * PRE n) + * (2 pow n)⁻¹ * (2 pow (n - 1))⁻¹ * + (&FACT (n - 1))⁻¹ * inv( &FACT n)] +End + +Definition logPoly_def: + logPoly 0 = [] ∧ + logPoly (SUC n) = + if (n = 0) then [0] + else (logPoly n ++ [ - 1 pow (SUC n) * inv (&n)]) +End + +(** Define an approximation function that translates transcendental functions into + polynomials **) +(* Error for exp if upper bound ≤ 1/2 *) +Definition expErrSmall_def: + expErrSmall approxSteps = inv (&FACT approxSteps * 2 pow (approxSteps - 1)) +End + +(* General, more coarse bound *) +Definition expErrBig_def: + expErrBig n approxSteps = + 2 pow n * &n pow approxSteps * inv (&FACT approxSteps * 2 pow approxSteps) +End + +Definition cosErr_def: + cosErr iv approxSteps = + (max (abs (FST iv)) (abs (SND iv))) pow approxSteps * (* ^(cosErr_EVAL_THM |> concl |> rhs)*) + inv (&FACT approxSteps) +End + +Definition sinErr_def: + sinErr iv approxSteps = + (max (abs (FST iv)) (abs (SND iv))) pow approxSteps * (* ^(sinErr_EVAL_THM |> concl |> rhs) *) + inv (&FACT approxSteps) +End + +Definition atnErr_def: + atnErr iv approxSteps = + (max (abs (FST iv)) (abs (SND iv))) pow approxSteps / + (1 - (max (abs (FST iv)) (abs (SND iv))) ) +End + +Definition sqrtErr_def: + sqrtErr iv approxSteps = + abs + (sum (0,approxSteps) + (λm. + (if m = 0 then 1 + else + &FACT (2 * PRE m) * + (2 pow m)⁻¹ * (2 pow (m − 1))⁻¹ * (&FACT (m − 1))⁻¹) / + &FACT m * (max (abs (FST iv)) (abs (SND iv))) pow approxSteps)) + + abs( -1 pow (approxSteps - 1) * &FACT (2 * PRE approxSteps) + * (2 pow approxSteps)⁻¹ * (2 pow (approxSteps - 1))⁻¹ * + (&FACT (approxSteps - 1))⁻¹ * inv( &FACT approxSteps) * + (max (abs (FST iv)) (abs (SND iv))) pow approxSteps) +End + +Definition logErr_def: + logErr iv approxSteps = + abs(-1 pow (SUC approxSteps) * + ((SND iv) pow approxSteps) / &approxSteps) +End + +(** + Approximate a function described by transcLang with a real-number polynomial, + also returns the approximation error incurred from the polynomial only +**) +Definition approxPoly_def: + approxPoly (transc:trFun) (iv:real#real) approxSteps :(poly#real) option = + case transc of + | Exp => + if iv = (0, inv 2) then + SOME (expPoly approxSteps, expErrSmall approxSteps) + else if 0 ≤ FST iv then + SOME (expPoly approxSteps, expErrBig (clg (SND iv * 2)) approxSteps) + else NONE + | Sin => SOME (sinPoly approxSteps, sinErr iv approxSteps) + | Cos => SOME (cosPoly approxSteps, cosErr iv approxSteps) + | Atn => + if max (abs (FST iv)) (abs (SND iv)) < 1 then SOME (atnPoly approxSteps, atnErr iv approxSteps) + else NONE + | Tan => NONE + | Sqrt => if ((1 < (FST iv)) ∧ (1 < (SND iv))) then + SOME (sqrtPoly approxSteps, sqrtErr iv approxSteps) else NONE + | Log => if ((1 < (FST iv)) ∧ (1 < (SND iv))) then + SOME (compose (logPoly approxSteps) [-1;1], logErr (FST iv -1, SND iv -1) approxSteps) else NONE +End + +(** Simple properties of polynomials used for proofs later **) +Theorem expPoly_LENGTH: + LENGTH (expPoly n) = n +Proof + Induct_on ‘n’ >> gs[expPoly_def] +QED + +Theorem cosPoly_LENGTH: + LENGTH (cosPoly n) = n +Proof + Induct_on ‘n’ >> gs[cosPoly_def] + >> cond_cases_tac >> gs[] +QED + +Theorem sinPoly_LENGTH: + LENGTH (sinPoly n) = n +Proof + Induct_on ‘n’ >> gs[sinPoly_def] + >> cond_cases_tac >> gs[] +QED + +Theorem sqrtPoly_LENGTH: + LENGTH (sqrtPoly n) = n +Proof + Induct_on ‘n’ >> gs[sqrtPoly_def] +QED + +Theorem logPoly_LENGTH: + LENGTH (logPoly n) = n +Proof + Induct_on ‘n’ >> gs[logPoly_def] + >> Cases_on ‘n’ >> gs[logPoly_def] +QED + +(** The polynomials compute the sum part of the McLaurin series **) +Theorem exp_sum_to_poly: + ∀ n x. evalPoly (expPoly n) x = sum (0,n) (λ m. x pow m / &FACT m) +Proof + Induct_on ‘n’ >> gs[expPoly_def, evalPoly_def, sum] + >> rpt strip_tac >> gs[evalPoly_app, evalPoly_def, expPoly_LENGTH] +QED + +Theorem cos_sum_to_poly: + ∀ n x. evalPoly (cosPoly n) x = + sum(0,n) + (λm. + (&FACT m)⁻¹ * x pow m * + if EVEN m then cos 0 * -1 pow (m DIV 2) + else sin 0 * -1 pow ((SUC m) DIV 2)) +Proof + Induct_on ‘n’ >> gs[sum, evalPoly_def, cosPoly_def] + >> cond_cases_tac + >> gs[evalPoly_app, COS_0, SIN_0, evalPoly_def, cosPoly_LENGTH] +QED + +Theorem sin_sum_to_poly: + ∀ n x. + evalPoly (sinPoly n) x = + sum(0,n) + (λm. + (&FACT m)⁻¹ * x pow m * + if EVEN m then sin 0 * -1 pow (m DIV 2) + else cos 0 * -1 pow ((m - 1) DIV 2)) +Proof + Induct_on ‘n’ >> gs[sum, evalPoly_def, sinPoly_def] + >> cond_cases_tac + >> gs[evalPoly_app, SIN_0, COS_0, evalPoly_def, sinPoly_LENGTH] +QED + +Theorem sqrt_sum_to_poly: + ∀n x. evalPoly (sqrtPoly n) x = + sum (0,n) + (λm. + (λm x. + if m = 0 then exp ((\x. (ln (1+x)) / &2) x) + else + -1 pow (m - 1) * &FACT (2 * PRE m) * + (exp ((\x. &(2 * PRE m + 1) * (ln (1+x)) / &2) x))⁻¹ + * (2 pow m)⁻¹ * + (2 pow (m - 1))⁻¹ * (&FACT (m - 1))⁻¹) m 0 / + &FACT m * x pow m) +Proof + Induct_on ‘n’ + >- gs[sum, sqrtPoly_def, evalPoly_def] + >> strip_tac >> gs[sqrtPoly_def, evalPoly_app, sum] + >> Cases_on ‘n=0’ + >- gs[sqrtPoly_def, LENGTH, FACT, evalPoly_def, LN_1, EXP_0] + >> gs[evalPoly_def, LN_1, EXP_0, sqrtPoly_LENGTH] +QED + +Theorem log_sum_to_poly: + ∀n x. (0 < n) ⇒ + evalPoly (logPoly n) x = + sum (0,n) (λm. -1 pow SUC m * x pow m / &m) +Proof + Induct_on ‘n’ + >- gs[] + >> rpt strip_tac + >> ‘0 ≤ n ’ by gs[] + >> Cases_on ‘n = 0’ + >- ( + rpt VAR_EQ_TAC + >> rewrite_tac[sum, REAL_ADD_LID, logPoly_def, APPEND_NIL] + >> BETA_TAC + >> rewrite_tac[evalPoly_def, REAL_MUL_RZERO, REAL_ADD_RID, ADD, + real_div] + >> ‘0 = -1 * 0:real’ by real_tac + >> rewrite_tac[pow0, REAL_MUL_RID, EVAL “-1 pow SUC 0”] + >> pop_assum $ once_rewrite_tac o single + >> AP_TERM_TAC >> rewrite_tac[REAL_MUL_RZERO] + >> gs[REAL_INV_EQ_0]) + >> gs[logPoly_def, sum, evalPoly_app, evalPoly_def, logPoly_LENGTH] +QED + +Theorem log_sum_to_poly_indexshift: + ∀ n x. (0 < n) ⇒ + evalPoly (compose (logPoly n) [-1;1]) x = + sum (0,n) (λm. -1 pow SUC m * (x-1) pow m / &m) +Proof + rpt strip_tac + >> rewrite_tac[compose_correct] + >> ‘evalPoly [-1; 1] x = x - 1’ by (gs[evalPoly_def] >> real_tac) + >> pop_assum $ once_rewrite_tac o single + >> irule log_sum_to_poly >> gs[] +QED + +(** Theorems about the remainder term of the McLaurin series **) +Theorem exp_remainder_bounded_small: + ∀ n x t. + 0 < n ∧ abs t ≤ abs x ∧ 0 ≤ x ∧ + t ≤ inv 2 ∧ x ≤ inv 2 ⇒ + abs (exp t / &FACT n * x pow n) ≤ inv (&FACT n * 2 pow (n - 1)) +Proof + rpt strip_tac >> rewrite_tac[real_div, abs] + >> qmatch_goalsub_abbrev_tac ‘(if 0 ≤ exp_bound then _ else _) ≤ _’ + >> ‘0 ≤ exp_bound’ + by ( + unabbrev_all_tac + >> rpt (irule REAL_LE_MUL >> gs[POW_POS, EXP_POS_LE])) + >> simp[] >> unabbrev_all_tac + >> irule REAL_LE_TRANS + >> qexists_tac ‘(1 + 2 * inv 2) * (inv (&FACT n) * x pow n)’ + >> conj_tac + >- ( + rewrite_tac[GSYM REAL_MUL_ASSOC] + >> irule REAL_LE_RMUL_IMP + >> conj_tac + >- ( + Cases_on ‘0 ≤ t’ + >- ( + irule REAL_LE_TRANS + >> qexists_tac ‘1 + 2 * t’ >> conj_tac + >- (irule REAL_EXP_BOUND_LEMMA >> gs[]) + >> real_tac) + >> ‘t = - (- t)’ by real_tac + >> pop_assum $ once_rewrite_tac o single + >> once_rewrite_tac[EXP_NEG] + >> ‘- (inv 2) ≤ -t’ by real_tac + >> irule REAL_LE_TRANS + >> qexists_tac ‘inv (exp (- (inv 2)))’ + >> conj_tac + >- (irule REAL_INV_LE_ANTIMONO_IMPR >> gs[EXP_POS_LT, EXP_MONO_LE]) + >> rewrite_tac[EXP_NEG, REAL_INV_INV] + >> irule REAL_EXP_BOUND_LEMMA >> gs[]) + >> irule REAL_LE_MUL >> gs[REAL_LE_INV, POW_POS]) + >> ‘1 + 2 * inv 2 = 2’ by gs[] + >> pop_assum $ rewrite_tac o single + >> rewrite_tac[GSYM REAL_MUL_ASSOC, REAL_INV_MUL'] + >> irule REAL_LE_TRANS + >> qexists_tac ‘2 * (inv (&FACT n) * inv 2 pow n)’ + >> conj_tac + >- ( + irule REAL_LE_LMUL_IMP >> reverse conj_tac >- gs[] + >> irule REAL_LE_LMUL_IMP >> reverse conj_tac >- gs[REAL_LE_INV] + >> irule POW_LE >> gs[]) + >> Cases_on ‘n’ >- gs[] + >> rewrite_tac[pow] + >> gs[REAL_INV_MUL'] +QED + +Theorem exp_remainder_bounded_big: + ∀ n m x t. + 0 < n ∧ abs t ≤ abs x ∧ EVEN n ∧ + abs x ≤ &m * (inv 2) ∧ + t ≤ &m * (inv 2) ⇒ + abs (exp t / &FACT n * x pow n) ≤ 2 pow m * &m pow n * (inv (&FACT n * 2 pow n)) +Proof + rpt strip_tac >> rewrite_tac[real_div, abs] + >> qmatch_goalsub_abbrev_tac ‘(if 0 ≤ exp_bound then _ else _) ≤ _’ + >> ‘0 ≤ exp_bound’ + by ( + unabbrev_all_tac + >> rpt (irule REAL_LE_MUL >> gs[POW_POS, EXP_POS_LE])) + >> pop_assum $ rewrite_tac o single + >> unabbrev_all_tac + >> irule REAL_LE_TRANS + >> qexists_tac ‘exp (&m * inv 2) * (inv (&FACT n) * x pow n)’ + >> conj_tac + >- ( + rewrite_tac[GSYM REAL_MUL_ASSOC] + >> irule REAL_LE_RMUL_IMP + >> conj_tac + >- gs[EXP_MONO_LE] + >> irule REAL_LE_MUL >> gs[REAL_LE_INV, POW_POS]) + >> rewrite_tac[EXP_N] + >> qmatch_goalsub_abbrev_tac ‘_ * cst_err ≤ _’ + >> irule REAL_LE_TRANS + >> qexists_tac ‘(1 + 2 * inv 2) pow m * cst_err’ + >> conj_tac + >- ( + irule REAL_LE_RMUL_IMP + >> conj_tac + >- ( + irule POW_LE >> rewrite_tac[EXP_POS_LE] + >> irule REAL_EXP_BOUND_LEMMA >> gs[]) + >> unabbrev_all_tac + >> irule REAL_LE_MUL >> gs[REAL_LE_INV, POW_POS]) + >> ‘1 + 2 * inv 2 = 2’ by gs[] + >> pop_assum $ rewrite_tac o single + >> unabbrev_all_tac + >> rewrite_tac[REAL_MUL_ASSOC] + >> qmatch_goalsub_abbrev_tac ‘cst_err * x pow n’ + >> irule REAL_LE_TRANS + >> qexists_tac ‘cst_err * (&m * inv 2) pow n’ >> conj_tac + >- ( + irule REAL_LE_LMUL_IMP >> conj_tac + >- (irule REAL_LE_TRANS >> qexists_tac ‘abs x pow n’ + >> gs[POW_LE, POW_ABS, ABS_LE]) + >> unabbrev_all_tac >> irule REAL_LE_MUL + >> gs[REAL_LE_INV, POW_POS]) + >> rewrite_tac [POW_MUL] + >> unabbrev_all_tac + >> qmatch_goalsub_abbrev_tac ‘curr_bound ≤ _’ + >> ‘curr_bound = 2 pow m * &m pow n * (inv (&FACT n * 2 pow n))’ + by (unabbrev_all_tac >> gs[REAL_POW_INV]) + >> pop_assum $ rewrite_tac o single + >> unabbrev_all_tac >> gs[] +QED + +Theorem sin_even_remainder_bounded: + ∀ n. + EVEN n ⇒ + inv (&FACT n) * sin t * x pow n * -1 pow (n DIV 2) ≤ + abs(inv (&FACT n) * x pow n * -1 pow (n DIV 2)) +Proof + rpt strip_tac + >> ‘inv (&FACT n) * x pow n * -1 pow (n DIV 2) = inv (&FACT n) * 1 * x pow n * -1 pow (n DIV 2)’ + by real_tac + >> pop_assum $ rewrite_tac o single + >> rewrite_tac[GSYM REAL_MUL_ASSOC] + >> once_rewrite_tac[REAL_ABS_MUL] + >> ‘0 ≤ inv (&FACT n)’ + by gs[REAL_LE_INV] + >> ‘abs (inv (&FACT n)) = inv (&FACT n)’ by gs[abs] + >> pop_assum $ rewrite_tac o single + >> irule REAL_LE_LMUL_IMP + >> reverse conj_tac >- gs[] + >> once_rewrite_tac[REAL_ABS_MUL] + >> Cases_on ‘0 ≤ x pow n * -1 pow (n DIV 2)’ + >- ( + ‘abs (x pow n * -1 pow (n DIV 2)) = x pow n * -1 pow (n DIV 2)’ by gs[abs] + >> pop_assum $ rewrite_tac o single + >> irule REAL_LE_RMUL_IMP >> gs[SIN_BOUNDS]) + >> ‘x pow n * -1 pow (n DIV 2) < 0’ by real_tac + >> irule REAL_LE_TRANS + >> qexists_tac ‘-1 * (x pow n * -1 pow (n DIV 2))’ + >> conj_tac + >- ( + once_rewrite_tac [REAL_MUL_COMM] + >> drule REAL_LE_LMUL_NEG + >> disch_then $ qspecl_then [‘sin t’, ‘-1’] $ rewrite_tac o single + >> gs[SIN_BOUNDS]) + >> ‘∃ y. x pow n * -1 pow (n DIV 2) = -1 * y ∧ 0 ≤ y’ + by (qexists_tac ‘-1 * x pow n * -1 pow (n DIV 2)’ + >> real_tac) + >> qpat_x_assum `_ = -1 * y` $ rewrite_tac o single + >> gs[ABS_LE] +QED + +Theorem cos_even_remainder_bounded: + ∀ n. + EVEN n ⇒ + inv (&FACT n) * cos t * x pow n * -1 pow (n DIV 2) ≤ + abs(inv (&FACT n) * x pow n * -1 pow (n DIV 2)) +Proof + rpt strip_tac + >> ‘inv (&FACT n) * x pow n * -1 pow (n DIV 2) = inv (&FACT n) * 1 * x pow n * -1 pow (n DIV 2)’ + by real_tac + >> pop_assum $ rewrite_tac o single + >> rewrite_tac[GSYM REAL_MUL_ASSOC] + >> once_rewrite_tac[REAL_ABS_MUL] + >> ‘0 ≤ inv (&FACT n)’ + by gs[REAL_LE_INV] + >> ‘abs (inv (&FACT n)) = inv (&FACT n)’ by gs[abs] + >> pop_assum $ rewrite_tac o single + >> irule REAL_LE_LMUL_IMP + >> reverse conj_tac >- gs[] + >> once_rewrite_tac[REAL_ABS_MUL] + >> Cases_on ‘0 ≤ x pow n * -1 pow (n DIV 2)’ + >- ( + ‘abs (x pow n * -1 pow (n DIV 2)) = x pow n * -1 pow (n DIV 2)’ by gs[abs] + >> pop_assum $ rewrite_tac o single + >> irule REAL_LE_RMUL_IMP >> gs[COS_BOUNDS]) + >> ‘x pow n * -1 pow (n DIV 2) < 0’ by real_tac + >> irule REAL_LE_TRANS + >> qexists_tac ‘-1 * (x pow n * -1 pow (n DIV 2))’ + >> conj_tac + >- ( + once_rewrite_tac [REAL_MUL_COMM] + >> drule REAL_LE_LMUL_NEG + >> disch_then $ qspecl_then [‘cos t’, ‘-1’] $ rewrite_tac o single + >> gs[COS_BOUNDS]) + >> ‘∃ y. x pow n * -1 pow (n DIV 2) = -1 * y ∧ 0 ≤ y’ + by (qexists_tac ‘-1 * x pow n * -1 pow (n DIV 2)’ + >> real_tac) + >> qpat_x_assum `_ = -1 * y` $ rewrite_tac o single + >> gs[ABS_LE] +QED + +Definition approxPolySideCond_def: + approxPolySideCond approxSteps = + (0 < approxSteps ∧ EVEN approxSteps ∧ EVEN (approxSteps DIV 2)) +End + +Theorem sum_sub: + ∀ (n:num) (f: num -> real) (g: num -> real). + sum (0, n) f - sum (0, n) g = sum (0,n) (\n. f n - g n) +Proof + Induct_on ‘n’ + >- gs[sum] + >> rpt strip_tac >> gs[sum] + >> ‘sum (0,n) f + f n − (sum (0,n) g + g n) = + ( sum (0,n) f − sum (0,n) g) + (f n - g n)’ by REAL_ARITH_TAC + >> pop_assum $ rewrite_tac o single + >> gs[] +QED + +Theorem SUM_LE: + ∀f g m n. + (∀r. m ≤ r ∧ r < n + m ⇒ f r <= g r) ∧ 0 < n ⇒ + sum (m,n) f <= sum (m,n) g +Proof + rpt strip_tac + >> Induct_on ‘n’ + >- gs[] + >> rpt strip_tac + >> gs[sum] + >> Cases_on ‘n=0’ + >- gs[sum] + >> ‘0 < n’ by gs[] >> res_tac + >> irule REAL_LE_ADD2 + >> gs[] +QED + +Theorem sum_abs_bound: + ∀n. 0< n ⇒ sum (0,n) (λm. abs (&m)⁻¹) ≤ &n +Proof + Induct_on ‘n’ + >- gs[] + >> Cases_on ‘n=0’ + >- ( pop_assum $ rewrite_tac o single + >> strip_tac + >> rewrite_tac[sum] >> BETA_TAC + >> rewrite_tac[ADD, REAL_ADD_LID] >> gs[] + ) + >> gs[sum, REAL] + >> rewrite_tac[GSYM REAL_OF_NUM_ADD] + >> irule REAL_LE_ADD2 >> conj_tac + >- gs[] + >> ‘ abs (&n)⁻¹ = inv (abs (&n))’ by gs[ABS_INV] + >> pop_assum $ rewrite_tac o single + >> irule REAL_INV_LE_1 >> gs[ABS_N] +QED + +Triviality POW4_MINUS1[simp]: + -1 pow (4 * x) = 1 +Proof + ‘4 * x = 2 * (2 * x)’ by gs[] + >> pop_assum $ once_rewrite_tac o single + >> rewrite_tac[POW_MINUS1] +QED + +Triviality POW4_DIV2[simp]: + -1 pow (4 * x DIV 2) = 1 +Proof + ‘4 * x = (x * 2) * 2’ by gs[] + >> pop_assum $ once_rewrite_tac o single + >> gs[MULT_DIV] +QED + +Theorem approxPoly_soundness: + ∀ transc iv approxSteps p err. + approxPolySideCond approxSteps ∧ + approxPoly transc iv approxSteps = SOME (p, err) ⇒ + ∀ x. + FST iv ≤ x ∧ x ≤ SND iv ⇒ + abs (getFun transc x - evalPoly p x) ≤ err +Proof + Cases_on ‘transc’ >> gs[approxPoly_def] + >> rpt strip_tac >> gs[approxPolySideCond_def] + (* exp function *) + >- ( + gs[interp_def, getFun_def] + >> Cases_on ‘iv = (0, inv 2)’ >> gs[] + (* exp function, 0 to 1/2 *) + >- ( + qspecl_then [‘x’, ‘approxSteps’] strip_assume_tac MCLAURIN_EXP_LE + >> pop_assum $ rewrite_tac o single + >> rpt VAR_EQ_TAC + >> rewrite_tac[exp_sum_to_poly] + >> qmatch_goalsub_abbrev_tac ‘abs (exp_taylor + taylor_rem - exp_taylor) ≤ _’ + >> ‘exp_taylor + taylor_rem - exp_taylor = taylor_rem’ by real_tac + >> pop_assum $ rewrite_tac o single + >> unabbrev_all_tac + >> ‘expErrSmall approxSteps = inv (&FACT approxSteps * 2 pow (approxSteps - 1))’ + by gs[expErrSmall_def] + >> rename1 ‘exp t’ + >> qspecl_then [‘approxSteps’, ‘x’,‘t’] mp_tac exp_remainder_bounded_small + >> impl_tac >> gs[] + >> real_tac) + (* exp function, 0 to 1 *) + >> ‘1 ≠ inv 2’ + by (once_rewrite_tac [GSYM REAL_INV1] + >> CCONTR_TAC + >> pop_assum $ mp_tac o SIMP_RULE std_ss [] + >> rewrite_tac[REAL_INV_INJ] >> real_tac) + >> rpt VAR_EQ_TAC + >> rewrite_tac[GSYM poly_compat, eval_simps] + >> pop_assum $ rewrite_tac o single + >> rewrite_tac[exp_sum_to_poly] + >> qspecl_then [‘x’, ‘approxSteps’] strip_assume_tac MCLAURIN_EXP_LE + >> pop_assum $ rewrite_tac o single + >> qmatch_goalsub_abbrev_tac ‘abs (exp_taylor + taylor_rem - exp_taylor) ≤ _’ + >> ‘exp_taylor + taylor_rem - exp_taylor = taylor_rem’ by real_tac + >> pop_assum $ rewrite_tac o single + >> unabbrev_all_tac + >> qmatch_goalsub_abbrev_tac ‘expErrBig n _’ + >> ‘expErrBig n approxSteps = + 2 pow n * &n pow approxSteps * inv (&FACT approxSteps * 2 pow approxSteps)’ + by (rewrite_tac[] >> gs[expErrBig_def]) + >> pop_assum $ rewrite_tac o single + >> qspecl_then [‘approxSteps’, ‘n’, ‘x’,‘t’] mp_tac exp_remainder_bounded_big + >> impl_tac + >- ( + rpt conj_tac >> TRY (gs[] >> real_tac >> NO_TAC) + >> ‘2 * x ≤ &n’ + by (unabbrev_all_tac >> cond_cases_tac + >> gs[] + >- ( + ‘SND iv = 0’ by real_tac + >> pop_assum $ rewrite_tac o single + >> ‘x = 0’ by real_tac + >> pop_assum $ rewrite_tac o single + >> gs[REAL_MUL_RZERO, REAL_DIV_LZERO, EVAL “flr 0”]) + >- ( + pop_assum $ rewrite_tac o single o GSYM + >> real_tac) + >> irule REAL_LE_TRANS + >> qexists_tac ‘&clg (2 * x)’ + >> gs[LE_NUM_CEILING] + >> cond_cases_tac >> gs[] + >> rewrite_tac[GSYM REAL_OF_NUM_LE] + >> irule REAL_LE_TRANS >> qexists_tac ‘&flr (2 * SND iv)’ + >> conj_tac + >> gs[REAL_OF_NUM_LE] + >> irule NUM_FLOOR_MONO + >> rpt conj_tac >> real_tac) + >- (‘0 ≤ x’ by real_tac >> gs[abs]) + >> irule REAL_LE_TRANS >> qexists_tac ‘abs t’ + >> conj_tac >- gs[ABS_LE] + >> irule REAL_LE_TRANS >> qexists_tac ‘abs x’ + >> ‘0 ≤ x’ by real_tac + >> gs[abs]) + >> rewrite_tac[]) + (* sin *) + >- ( + gs[interp_def, getFun_def] >> rpt VAR_EQ_TAC + >> qspecl_then [‘x’, ‘approxSteps’] strip_assume_tac MCLAURIN_SIN_LE + >> gs[] + >> pop_assum $ rewrite_tac o single + >> gs[sin_sum_to_poly] + >> qmatch_goalsub_abbrev_tac ‘abs (sin_taylor + taylor_rem - sin_taylor) ≤ _’ + >> ‘sin_taylor + taylor_rem - sin_taylor = taylor_rem’ by real_tac + >> pop_assum $ rewrite_tac o single + >> unabbrev_all_tac + >> ‘inv (&FACT approxSteps) * sin t * x pow approxSteps * -1 pow (approxSteps DIV 2) = + (sin t * ((x pow approxSteps) * inv (&FACT approxSteps) * -1 pow (approxSteps DIV 2)))’ + by real_tac + >> ‘-(x pow approxSteps) * inv (&FACT approxSteps) * sin t = + -(sin t * ((x pow approxSteps) * inv (&FACT approxSteps)))’ + by real_tac + >> rewrite_tac [] + >> ntac 2 $ pop_assum $ rewrite_tac o single + >> rewrite_tac[GSYM REAL_MUL_ASSOC] + >> qmatch_goalsub_abbrev_tac ‘_ * err_sin_concr’ + >> rewrite_tac [ABS_NEG, Once ABS_MUL] + >> irule REAL_LE_TRANS + >> qexists_tac ‘ 1 * abs err_sin_concr’ >> conj_tac + >- (irule REAL_LE_RMUL_IMP >> unabbrev_all_tac >> gs[SIN_BOUND, ABS_POS]) + >> rewrite_tac [REAL_MUL_LID, sinErr_def, ABS_MUL] + >> ‘abs err_sin_concr = err_sin_concr’ + by (unabbrev_all_tac + >> rewrite_tac[ABS_REFL] + >> irule REAL_LE_MUL >> conj_tac + >> gs[REAL_POW_GE0] + >> irule REAL_LE_MUL >> gs[REAL_POS, REAL_POW_GE0]) + >> pop_assum $ rewrite_tac o single + >> unabbrev_all_tac + >> rewrite_tac [sinErr_def] + >> imp_res_tac EVEN_ODD_EXISTS >> gs[POW_MINUS1] + >> irule REAL_LE_LMUL_IMP >> gs[POW_ABS] + >> irule REAL_LE_TRANS + >> qexists_tac ‘abs (x pow (2 * m'))’ >> gs[ABS_LE, POW_ABS] + >> rewrite_tac[GSYM POW_ABS] + >> irule POW_LE >> gs[ABS_POS] + >> irule RealSimpsTheory.maxAbs >> gs[]) + (* cos function *) + >- ( + gs[interp_def, getFun_def] >> rpt VAR_EQ_TAC + >> qspecl_then [‘x’, ‘approxSteps’] strip_assume_tac MCLAURIN_COS_LE + >> gs[] + >> pop_assum $ rewrite_tac o single + >> gs[cos_sum_to_poly] + >> qmatch_goalsub_abbrev_tac ‘abs (cos_taylor + taylor_rem - cos_taylor) ≤ _’ + >> ‘cos_taylor + taylor_rem - cos_taylor = taylor_rem’ by real_tac + >> pop_assum $ rewrite_tac o single + >> unabbrev_all_tac + >> ‘(x pow approxSteps) * cos t * inv (&FACT approxSteps) = + (cos t * ((x pow approxSteps) * inv (&FACT approxSteps)))’ + by real_tac + >> ‘-(x pow approxSteps) * cos t * inv (&FACT approxSteps) = + -(cos t * ((x pow approxSteps) * inv (&FACT approxSteps)))’ + by real_tac + >> rewrite_tac [] + >> ntac 2 $ pop_assum $ rewrite_tac o single + >> rewrite_tac [GSYM REAL_MUL_ASSOC] + >> qmatch_goalsub_abbrev_tac ‘abs (cos _ * err_cos_concr)’ + >> irule REAL_LE_TRANS + >> qexists_tac ‘ 1 * abs err_cos_concr’ >> conj_tac + >- (rewrite_tac[ABS_MUL] >> irule REAL_LE_RMUL_IMP >> unabbrev_all_tac >> gs[COS_BOUND, ABS_POS]) + >> rewrite_tac[REAL_MUL_LID] + >> ‘abs err_cos_concr = err_cos_concr’ + by (unabbrev_all_tac + >> rewrite_tac[ABS_REFL] + >> irule REAL_LE_MUL >> conj_tac + >- (irule REAL_LE_INV >> gs[REAL_POS]) + >> irule REAL_LE_MUL >> conj_tac + >> gs[REAL_POW_GE0]) + >> pop_assum $ rewrite_tac o single + >> unabbrev_all_tac + >> rewrite_tac [cosErr_def] + >> imp_res_tac EVEN_ODD_EXISTS >> gs[POW_MINUS1] + >> irule REAL_LE_LMUL_IMP >> gs[GSYM POW_ABS] + >> irule REAL_LE_TRANS + >> qexists_tac ‘abs (x pow (2 * m'))’ >> gs[ABS_LE, POW_ABS] + >> rewrite_tac [GSYM POW_ABS] + >> irule POW_LE >> gs[ABS_POS] + >> irule RealSimpsTheory.maxAbs >> gs[]) + (* atn *) + >- ( + gs[interp_def, getFun_def] >> rpt VAR_EQ_TAC + >> qspecl_then [‘x’, ‘approxSteps’] mp_tac MCLAURIN_ATN + >> impl_tac + >- ( + irule REAL_LET_TRANS >> qexists_tac ‘max (abs (FST iv)) (abs (SND iv))’ + >> gs[RealSimpsTheory.maxAbs]) + >> strip_tac + >> gs[atnPoly_correct] + >> irule REAL_LE_TRANS + >> qexists_tac ‘abs x pow approxSteps / (1 - abs x)’ >> gs[atnErr_def] + >> rewrite_tac[real_div] + >> irule REAL_LE_MUL2 >> rpt conj_tac + >- ( + irule POW_LE >> gs[ABS_POS] + >> gs[RealSimpsTheory.maxAbs]) + >- ( + irule REAL_LE_INV2 >> rpt conj_tac + >- gs[REAL_SUB_LT] + >> rewrite_tac [real_sub] + >> irule REAL_LE_LADD_IMP + >> gs[REAL_LE_NEG] + >> irule RealSimpsTheory.maxAbs >> gs[]) + >- ( + irule POW_POS >> gs[ABS_POS]) + >> irule REAL_LE_INV + >> gs[REAL_SUB_LE] + >> ‘abs x < 1’ suffices_by real_tac + >> irule REAL_LET_TRANS + >> qexists_tac ‘max (abs (FST iv)) (abs (SND iv))’ >> gs[] + >> gs[RealSimpsTheory.maxAbs]) + (* sqrt *) + >- ( + gs[interp_def, getFun_def] + >> qspecl_then [‘x-1’, ‘approxSteps’] mp_tac MCLAURTIN_SQRT_LE + >> impl_tac + >- ( gs[GSYM REAL_LT_ADD_SUB] + >> irule REAL_LTE_TRANS + >> qexists_tac ‘FST iv’ >> gs[] + ) + >> strip_tac + >> rewrite_tac[sqrt_sum_to_poly, sqrtErr_def] + >> pop_assum mp_tac + >> BETA_TAC + >> ‘(1 + (x − 1)) = x’ by REAL_ARITH_TAC + >> ASM_REWRITE_TAC[] + >> ‘sqrt (x) = exp ((\x. (ln (x)) / &2) x)’ by + ( irule SQRT_EXPLN_GENERAL + >> irule REAL_LTE_TRANS + >> qexists_tac ‘FST iv’ >> gs[] + >> irule REAL_LT_TRANS + >> qexists_tac ‘&1’ >> gs[] + ) + >> ASM_REWRITE_TAC[] + >> strip_tac >> BETA_TAC >> ASM_REWRITE_TAC[] + >> ‘approxSteps ≠ 0 ’ by gs[] + >> pop_assum $ rewrite_tac o single + >> ‘∀ x y z: real. x + y -z = -(z-x) + y’ by REAL_ARITH_TAC + >> pop_assum $ rewrite_tac o single + >> rewrite_tac[sum_sub] + >> irule REAL_LE_TRANS + >> qexists_tac ‘abs + (- sum (0,approxSteps) + (λn. + (λm. + (if m = 0 then exp (ln (1 + 0) / 2) + else + -1 pow (m − 1) * &FACT (2 * PRE m) * + (exp (&(2 * PRE m + 1) * ln (1 + 0) / 2))⁻¹ * + (2 pow m)⁻¹ * (2 pow (m − 1))⁻¹ * + (&FACT (m − 1))⁻¹) / &FACT m * x pow m) n − + (λm. + (if m = 0 then exp (ln (1 + 0) / 2) + else + -1 pow (m − 1) * &FACT (2 * PRE m) * + (exp (&(2 * PRE m + 1) * ln (1 + 0) / 2))⁻¹ * + (2 pow m)⁻¹ * (2 pow (m − 1))⁻¹ * + (&FACT (m − 1))⁻¹) / &FACT m * (x-1) pow m) n)) + + abs ( -1 pow (approxSteps − 1) * + &FACT (2 * PRE approxSteps) * + (exp (&(2 * PRE approxSteps + 1) * ln (1 + t) / 2))⁻¹ * + (2 pow approxSteps)⁻¹ * (2 pow (approxSteps − 1))⁻¹ * + (&FACT (approxSteps − 1))⁻¹ / &FACT approxSteps * + (x − 1) pow approxSteps) ’ + >> conj_tac + >- gs[ABS_TRIANGLE] + >> rewrite_tac[ABS_NEG] + >> ‘(λn. + (λm. + (if m = 0 then exp (ln (1 + 0) / 2) + else + -1 pow (m − 1) * &FACT (2 * PRE m) * + (exp (&(2 * PRE m + 1) * ln (1 + 0) / 2))⁻¹ * + (2 pow m)⁻¹ * (2 pow (m − 1))⁻¹ * (&FACT (m − 1))⁻¹) / + &FACT m * x pow m) n − + (λm. + (if m = 0 then exp (ln (1 + 0) / 2) + else + -1 pow (m − 1) * &FACT (2 * PRE m) * + (exp (&(2 * PRE m + 1) * ln (1 + 0) / 2))⁻¹ * + (2 pow m)⁻¹ * (2 pow (m − 1))⁻¹ * (&FACT (m − 1))⁻¹) / + &FACT m * (x − 1) pow m) n) = + \m. (if m = 0 then exp (ln (1 + 0) / 2) + else + -1 pow (m − 1) * &FACT (2 * PRE m) * + (exp (&(2 * PRE m + 1) * ln (1 + 0) / 2))⁻¹ * + (2 pow m)⁻¹ * (2 pow (m − 1))⁻¹ * (&FACT (m − 1))⁻¹) / + &FACT m * (x pow m - (x-1) pow m)’ + by + ( gs[FUN_EQ_THM] >> rpt strip_tac + >> cond_cases_tac + >- gs[] + >> real_tac + ) + >> pop_assum $ rewrite_tac o single + >> irule REAL_LE_ADD2 >> conj_tac + >- ( gs[LN_1, EXP_0] + >> irule REAL_LE_TRANS + >> qexists_tac ‘sum (0,approxSteps) + (λm. abs + ( (&FACT m)⁻¹ * (x pow m − (x − 1) pow m) * + if m = 0 then 1 + else + &FACT (2 * PRE m) * (&FACT (m − 1))⁻¹ * + -1 pow (m − 1) * (2 pow m)⁻¹ * (2 pow (m − 1))⁻¹))’ + >> conj_tac + >- gs[SUM_ABS_LE] + >> ‘ (λm. + (&FACT m)⁻¹ * + max (abs (FST iv)) (abs (SND iv)) pow approxSteps * + if m = 0 then 1 + else + &FACT (2 * PRE m) * (&FACT (m − 1))⁻¹ * + (2 pow m)⁻¹ * (2 pow (m − 1))⁻¹) = + (λm. abs + ((\m. (&FACT m)⁻¹ * + max (abs (FST iv)) (abs (SND iv)) pow approxSteps * + if m = 0 then 1 + else + &FACT (2 * PRE m) * (&FACT (m − 1))⁻¹ * + (2 pow m)⁻¹ * (2 pow (m − 1))⁻¹) m))’ by + ( gs[FUN_EQ_THM] >> rpt strip_tac + >> cond_cases_tac + >- gs[REAL_MUL_RID, FACT] + >> irule REAL_LE_MUL + >> conj_tac + >- ( irule REAL_LE_MUL + >> conj_tac + >- ( irule REAL_LT_IMP_LE + >> irule REAL_INV_POS >> irule REAL_NZ_IMP_LT + >> ‘∀ m: num. 0 < m ⇒ m ≠ 0’ by gs[] + >> first_assum irule + >> gs[FACT_LESS] + ) + >> irule POW_POS + >> gs[REAL_LE_MAX] + ) + >> gs[] >> irule REAL_LE_MUL + >> conj_tac + >- ( irule REAL_LT_IMP_LE >> irule REAL_NZ_IMP_LT + >> ‘∀ m: num. 0 < m ⇒ m ≠ 0’ by gs[] + >> first_assum irule + >> gs[FACT_LESS] + ) + >> irule REAL_LT_IMP_LE + >> irule REAL_INV_POS >> irule REAL_NZ_IMP_LT + >> ‘∀ m: num. 0 < m ⇒ m ≠ 0’ by gs[] + >> first_assum irule + >> gs[FACT_LESS] + ) + >> pop_assum $ once_rewrite_tac o single + >> once_rewrite_tac[SUM_ABS] + >> irule SUM_LE >> conj_tac + >- (rpt strip_tac + >> BETA_TAC + >> cond_cases_tac + >- gs[] + >> gs[ABS_MUL] + >> ‘abs (&FACT r)⁻¹ * abs (&FACT (r − 1))⁻¹ * + abs (x pow r − (x − 1) pow r) * &FACT (2 * PRE r) = + (abs (&FACT r)⁻¹ * abs (&FACT (r − 1))⁻¹ * &FACT (2 * PRE r))* + abs (x pow r − (x − 1) pow r)’ by real_tac + >> pop_assum $ rewrite_tac o single + >> ‘ abs (&FACT r)⁻¹ * abs (&FACT (r − 1))⁻¹ * + abs (max (abs (FST iv)) (abs (SND iv)) pow approxSteps) * + &FACT (2 * PRE r) = + (abs (&FACT r)⁻¹ * abs (&FACT (r − 1))⁻¹ * &FACT (2 * PRE r))* + abs (max (abs (FST iv)) (abs (SND iv)) pow approxSteps)’ by + real_tac + >> pop_assum $ rewrite_tac o single + >> irule REAL_LE_MUL2 + >> gs[] >> rpt conj_tac + >- ( ‘abs (x pow r − (x − 1) pow r) = + (x pow r − (x − 1) pow r)’ by + ( ‘0 ≤ x pow r − (x − 1) pow r’ by + ( ‘∀x y:real. x ≤ y ⇒ 0 ≤ y - x’ by REAL_ARITH_TAC + >> first_assum irule + >> irule POW_LE >> real_tac + ) + >> gs[ABS_REFL] + ) + >> pop_assum $ rewrite_tac o single + >> ‘abs (max (abs (FST iv)) (abs (SND iv)) pow approxSteps) = + (max (abs (FST iv)) (abs (SND iv)) pow approxSteps) ’ by + ( ‘0≤ (max (abs (FST iv)) (abs (SND iv)) pow approxSteps)’ + by + ( irule POW_POS + >> gs[REAL_LE_MAX] + ) + >> gs[ABS_REFL] + ) + >> pop_assum $ rewrite_tac o single + >> irule REAL_LE_TRANS + >> qexists_tac ‘x pow r’ + >> conj_tac + >- ( ‘∀ x y: real. 0 ≤ x ∧ 0≤ y ∧ y ≤ x ⇒ + x - y ≤ x’ by REAL_ARITH_TAC + >> first_assum irule + >> rpt conj_tac + >- ( irule POW_LE >> real_tac ) + >- ( irule POW_POS >> real_tac ) + >> irule POW_POS >> real_tac + ) + >> irule REAL_LE_TRANS + >> qexists_tac ‘x pow approxSteps’ + >> conj_tac + >- ( irule REAL_POW_MONO + >> gs[] >> real_tac + ) + >> irule POW_LE + >> conj_tac + >- ( irule REAL_LE_TRANS + >> qexists_tac ‘SND iv’ + >> conj_tac + >- gs[] + >> irule REAL_LE_TRANS + >> qexists_tac ‘abs (SND iv)’ + >> conj_tac + >- gs[ABS_LE] + >> irule REAL_LE_MAX2 + ) + >> real_tac + ) + >> irule REAL_LE_MUL >> gs[] + >> irule REAL_LE_MUL >> gs[] + ) + >> gs[] + ) + >> once_rewrite_tac[real_div] >> gs[ABS_MUL] + >> ‘abs (exp (ln (1 + t) * &(2 * PRE approxSteps + 1) / 2))⁻¹ * + abs (&FACT approxSteps)⁻¹ * abs (&FACT (approxSteps − 1))⁻¹ * + abs ((x − 1) pow approxSteps) * &FACT (2 * PRE approxSteps) = + ( abs (&FACT approxSteps)⁻¹ * abs (&FACT (approxSteps − 1))⁻¹ * + &FACT (2 * PRE approxSteps)) * + (abs (exp (ln (1 + t) * &(2 * PRE approxSteps + 1) / 2))⁻¹ * + abs ((x − 1) pow approxSteps)) ’ by real_tac + >> pop_assum $ rewrite_tac o single + >> ‘abs (&FACT approxSteps)⁻¹ * abs (&FACT (approxSteps − 1))⁻¹ * + abs (max (abs (FST iv)) (abs (SND iv)) pow approxSteps) * + &FACT (2 * PRE approxSteps) = + ( abs (&FACT approxSteps)⁻¹ * abs (&FACT (approxSteps − 1))⁻¹ * + &FACT (2 * PRE approxSteps)) * + ( abs (max (abs (FST iv)) (abs (SND iv)) pow approxSteps))’ by + real_tac + >> pop_assum $ rewrite_tac o single + >> irule REAL_LE_MUL2 + >> gs[] + >> rpt conj_tac + >- ( ‘abs (max (abs (FST iv)) (abs (SND iv)) pow approxSteps) = + &1 * abs (max (abs (FST iv)) (abs (SND iv)) pow approxSteps)’ by + gs[] + >> pop_assum $ once_rewrite_tac o single + >> irule REAL_LE_MUL2 + >> gs[] >> conj_tac + >- ( ‘ 0 ≠ (exp (ln (1 + t) * &(2 * PRE approxSteps + 1) / 2))’ + by gs[EXP_NZ] + >> ‘0 ≠ (exp + (1 / 2 * + (ln (1 ) * + &(2 * PRE approxSteps + 1))))’ + by gs[EXP_NZ] + >> gs[ABS_INV] + >> ‘0 ≤ exp (ln (1 + t) * &(2 * PRE approxSteps + 1) / 2)’ by + gs[EXP_POS_LE] + >> ‘abs (exp (ln (1 + t) * &(2 * PRE approxSteps + 1) / 2)) = + exp (ln (1 + t) * &(2 * PRE approxSteps + 1) / 2)’ by + gs[ABS_REFL] + >> pop_assum $ rewrite_tac o single + >> ‘1 = exp 0’ by gs[EXP_0] + >> pop_assum $ rewrite_tac o single + >> gs[EXP_MONO_LE] + >> gs[EXP_0] + >> irule REAL_LE_MUL + >> conj_tac + >- ( irule LN_POS >> real_tac ) + >> gs[] + ) + >> ‘ abs ((x − 1) pow approxSteps) = ((x − 1) pow approxSteps)’ by + ( ‘0 ≤ ((x − 1) pow approxSteps)’ by + ( irule POW_POS + >> real_tac + ) + >> gs[ABS_REFL] + ) + >> pop_assum $ rewrite_tac o single + >> ‘abs (max (abs (FST iv)) (abs (SND iv)) pow approxSteps) = + (max (abs (FST iv)) (abs (SND iv)) pow approxSteps)’ by + ( ‘0 ≤ max (abs (FST iv)) (abs (SND iv)) pow approxSteps’ by + ( irule POW_POS + >> gs[REAL_LE_MAX] + ) + >> gs[ABS_REFL] + ) + >> pop_assum $ rewrite_tac o single + >> irule POW_LE + >> conj_tac + >- ( irule REAL_LE_TRANS + >> qexists_tac ‘x’ >> conj_tac + >- real_tac + >> irule REAL_LE_TRANS >> qexists_tac ‘SND iv’ + >> gs[] + >> irule REAL_LE_TRANS + >> qexists_tac ‘abs (SND iv)’ >> conj_tac + >- gs[ABS_LE] + >> gs[REAL_LE_MAX2] + ) + >> real_tac + ) + >- ( once_rewrite_tac[GSYM REAL_MUL_ASSOC] + >> irule REAL_LE_MUL + >> gs[] + >> irule REAL_LE_MUL >> gs[] + ) + >> once_rewrite_tac[GSYM REAL_MUL_ASSOC] + >> irule REAL_LE_MUL >> gs[] + ) + (* ln *) + >> gs[interp_def, getFun_def] + >> qspecl_then [‘x-1’, ‘approxSteps’] mp_tac MCLAURIN_LN_POS + >> impl_tac + >- ( + gs[] >> gs[GSYM REAL_LT_ADD_SUB] + >> irule REAL_LTE_TRANS + >> qexists_tac ‘FST iv’ >> gs[]) + >> strip_tac + >> gs[log_sum_to_poly_indexshift] + >> ‘(1 + (x − 1)) = x’ by REAL_ARITH_TAC + >> gs[] + >> pop_assum $ kall_tac + >> qspecl_then [‘approxSteps’, ‘x’] mp_tac log_sum_to_poly_indexshift + >> impl_tac >- gs[] + >> disch_then $ rewrite_tac o single + >> ‘∀ x y z: real. x + y - z = (x - z) + y’ by REAL_ARITH_TAC + >> pop_assum $ rewrite_tac o single + >> rewrite_tac[logErr_def, REAL_SUB_REFL, REAL_ADD_LID, real_div, ABS_MUL] + >> rewrite_tac [GSYM REAL_MUL_ASSOC] + >> irule REAL_LE_LMUL_IMP >> reverse conj_tac + >- gs[ABS_POS] + >> irule REAL_LE_MUL2 + >> ‘abs (SND iv - 1) = SND iv - 1’ by real_tac + >> rpt conj_tac >> gs[ABS_POS, GSYM POW_ABS] + >- ( + irule POW_LE >> gs[ABS_POS] + >> ‘0 ≤ x - 1’ by real_tac + >> gs[abs] >> real_tac) + >> ‘0 ≤ &approxSteps * (1 + t) pow approxSteps’ + by (irule REAL_LE_MUL >> conj_tac >> gs[]) + >> gs[abs, REAL_INV_MUL'] + >> once_rewrite_tac [GSYM REAL_INV1] + >> irule REAL_LE_INV2 >> rpt conj_tac >> gs[] + >> qspec_then ‘approxSteps’ (once_rewrite_tac o single) $ GSYM POW_ONE + >> irule POW_LE >> gs[] >> real_tac + (* Tan function missing here as they are unimplemented *) +QED + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/checkerDefsScript.sml b/floatingPoint/tools/dandelion/checkerDefsScript.sml new file mode 100644 index 0000000000..aa6a42b033 --- /dev/null +++ b/floatingPoint/tools/dandelion/checkerDefsScript.sml @@ -0,0 +1,81 @@ +(** + Basic definitions used by Dandelion +**) +open realTheory realLib RealArith stringTheory; +open renameTheory realPolyTheory transcLangTheory; +open preambleDandelion; + +val _ = new_theory"checkerDefs"; + +Datatype: + certificate = + <| + transc : transc; (* transcendental function to be approximated *) + poly : poly; (* real-number polynomial approximation *) + eps : real; (* approximation error *) + iv: ((string#(real#real)) list); (* the interval on which the function is approximated *) + |> +End + +Datatype: + result = Valid (* the checker succeeded *) + | Invalid string (* the checker failed with an error message *) +End + +Definition isValid_def: + isValid b err = if b then Valid else Invalid err +End + +Definition interpResult_def: + interpResult (Valid) = T ∧ + interpResult _ = F +End + +Datatype: + transcCertAnn = + Cert certificate + | PolyCert poly transcCertAnn + | BopCert binop transcCertAnn transcCertAnn + | UopCert unop transcCertAnn + | CstCert real + | VarCert string +End + +Definition interpCertAnn_def: + interpCertAnn (VarCert x) env = + do v <- FIND (λ (y,r). y = x) env; + return (SND v); + od ∧ + interpCertAnn (CstCert c) env = SOME c ∧ + interpCertAnn (UopCert uop t) env = + do + r <- interpCertAnn t env; + assert (uop = Inv ⇒ r ≠ 0); + return (appUop uop r) + od ∧ + interpCertAnn (BopCert bop t1 t2) env = + do + r1 <- interpCertAnn t1 env; + r2 <- interpCertAnn t2 env; + assert (bop = Div ⇒ r2 ≠ 0); + return (appBop bop r1 r2); + od ∧ + interpCertAnn (Cert c) env = + do + r <- interp c.transc env; + return r; + od ∧ + interpCertAnn (PolyCert p t) env = + do + r <- interpCertAnn t env; + return (evalPoly p r) + od +End + +Datatype: + transcCertProg = + Let string transcCertAnn transcCertAnn + | Ret transcCertAnn +End + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/checkerScript.sml b/floatingPoint/tools/dandelion/checkerScript.sml new file mode 100644 index 0000000000..e360e68a18 --- /dev/null +++ b/floatingPoint/tools/dandelion/checkerScript.sml @@ -0,0 +1,340 @@ +(** + Define high-level functions used by Dandelion and prove their + soundness by composing soundness proofs from the included files +**) +open realTheory realLib RealArith stringTheory polyTheory transcTheory; +open renameTheory realPolyTheory transcLangTheory sturmComputeTheory sturmTheory + drangTheory checkerDefsTheory pointCheckerTheory mcLaurinApproxTheory + realPolyProofsTheory approxPolyTheory transcIntvSemTheory + transcApproxSemTheory transcReflectTheory; +(* open bitArithLib; *) +open preambleDandelion; + +val _ = new_theory "checker"; + +(** + Checks that the zero intervals encoded in the certificate actually are + all of the zeros of derivative of the difference between the approximated + polynomial and the transcendental function +**) +Definition numZeros_def: + numZeros deriv1 deriv2 iv sseq = + let numZeros = + (variation (MAP (λp. poly p (FST iv)) (deriv1::deriv2::sseq)) - + variation (MAP (λp. poly p (SND iv)) (deriv1::deriv2::sseq))) + in + if (poly deriv1 (FST iv) = 0) then + (Invalid "Lower bound of derivative is 0", 0) + else if (poly deriv1 (SND iv) = 0) then + (Invalid "Upper bound of derivative is 0", 0) + else (Valid, numZeros) +End + +Definition getMaxWidth_def: + getMaxWidth [] = 0 /\ + getMaxWidth ((u,v)::xs) = max (abs(u-v)) (getMaxWidth xs) +End + +Definition getMaxAbsLb_def: + getMaxAbsLb p [] = 0 ∧ + getMaxAbsLb p ((u,v)::xs) = max (abs (poly p u)) (getMaxAbsLb p xs) +End + +Definition validBounds_def: + validBounds iv [] = T ∧ + validBounds (iv:real#real) (zeroIv::zeros) = + (FST iv ≤ FST zeroIv ∧ SND zeroIv ≤ SND iv ∧ validBounds iv zeros) +End + +(** + Either find a sublist of length n where P is true, or return the empty list +**) +Definition findN_def: + findN n P l = + let subL = FILTER P l in + if (LENGTH subL = n) then subL else [] +End + +(** + Checks that the certificate encoded error eps is an upper bound to the + error that can be proven in HOL4. + The provable error is computed following the assumptions of theorem + BOUND_THEOREM_INEXACT. + First we compute the maximum absolute value of the input interval + and use it to get an upper bound on the maxmimum value of the derivate B. + The error e, i.e. the width of the intervals in which the zeros can be + found is computed using function getMaxWidth, + and finally the upper bound ub is computed using function getMaxAbsLb. + After computing these values, only the outer points of the interval need + to be validated. +**) +Definition validateZerosLeqErr_def: + validateZerosLeqErr errorp iv zeros eps numZeros = + let mAbs = max (abs (FST iv)) (abs (SND iv)); + realZeros = (findN numZeros (λ (u,v). poly (diff errorp) u * poly (diff errorp) v ≤ 0) zeros); + B = poly (MAP abs (diff errorp)) mAbs; + e = getMaxWidth realZeros; + ub = getMaxAbsLb errorp realZeros; + globalErr = max (abs (poly errorp (FST iv))) + (max (abs (poly errorp (SND iv))) + (ub + B * e)) + in + if ~ (validBounds iv realZeros ∧ recordered (FST iv) realZeros (SND iv)) then + (Invalid "Zeros not correctly spaced", 0) + else if LENGTH realZeros < numZeros then + (Invalid "Did not find sufficient zeros", 0) + else if globalErr ≤ eps + then (Valid, globalErr) + else (Invalid "Bounding error too large", 0) +End + +(** + Overall certificate checker combines all of the above functions into one that + runs over the full certificate **) +Definition checker_def: + checker (cert:certificate) approxSteps zeroGuess :checkerDefs$result = + if ~ EVEN approxSteps ∨ ~ EVEN (approxSteps DIV 2) ∨ approxSteps = 0 ∨ LENGTH cert.iv ≠ 1 + then Invalid "Need even number of approximation steps" + else + (** Interval bounds **) + case interpIntv cert.transc cert.iv of + | NONE => Invalid "Could not compute IV bounds" + | SOME ivAnn => + (** High-accuracy Taylor series **) + case approxTransc <| steps := approxSteps |> ivAnn of + | NONE => Invalid "Could not compute high-accuracy series" + | SOME errAnn => + (** Get a polynomial representation **) + case reflectToPoly (erase errAnn) (FST (HD cert.iv)) of + | NONE => Invalid "Could not translate to polynomial" + | SOME transp => + let errorp = transp -p cert.poly; + deriv1 = diff errorp; + deriv2 = diff deriv1; + in + if ~(FST (SND (HD cert.iv)) ≤ SND (SND (HD cert.iv))) + then Invalid "Internal error" + else + case sturm_seq deriv1 deriv2 of + NONE => Invalid "Could not compute sturm sequence" + | SOME sseq => + case numZeros deriv1 deriv2 (SND (HD cert.iv)) sseq of + | (Invalid s, _) => Invalid s + | (Valid, zeros ) => + FST (validateZerosLeqErr errorp (SND (HD cert.iv)) zeroGuess (cert.eps - (getAnn errAnn)) zeros) +End + +Theorem numZeros_sound: + ∀ sseq deriv1 iv. + sturm_seq deriv1 (diff deriv1) = SOME sseq ∧ + numZeros deriv1 (diff deriv1) iv sseq = (Valid, n) ∧ + FST iv ≤ SND iv ⇒ + {x | FST iv ≤ x ∧ x ≤ SND iv ∧ (poly deriv1 x = &0)} HAS_SIZE n +Proof + rpt gen_tac + >> rewrite_tac[numZeros_def] + >> CONV_TAC $ DEPTH_CONV let_CONV + >> rpt (cond_cases_tac >- gs[]) + >> rpt $ pop_assum $ mp_tac o SIMP_RULE std_ss [] + >> rpt strip_tac + >> qpat_x_assum ‘_ = (_, n)’ $ strip_assume_tac o REWRITE_RULE [PAIR_EQ] + >> pop_assum $ once_rewrite_tac o single o GSYM + >> imp_res_tac sturm_seq_equiv + >> irule STURM_THEOREM >> gs[] +QED + +Theorem getMaxWidth_is_max: + ∀ l. EVERY (λ (u,v). abs (u - v) <= getMaxWidth l) l +Proof + Induct_on ‘l’ >> rpt strip_tac >> gs[getMaxWidth_def] + >> rename1 ‘getMaxWidth (iv1::ivs)’ + >> PairCases_on ‘iv1’ >> rename1 ‘getMaxWidth ((iv1Lo, iv1Hi)::ivs)’ + >> gs[getMaxWidth_def, max_def] + >> cond_cases_tac >> gs[] + >> ‘getMaxWidth ivs < abs (iv1Lo - iv1Hi)’ by real_tac + >> irule EVERY_MONOTONIC + >> qexists_tac ‘λ (u,v). abs (u - v) <= getMaxWidth ivs’ >> gs[] + >> rpt strip_tac >> Cases_on ‘x’ >> gs[] + >> real_tac +QED + +Theorem getMaxAbsLb_is_max: + ∀ (l:(real#real) list) p. EVERY (λ (u,v). abs (poly p u) ≤ getMaxAbsLb p l) l +Proof + Induct_on ‘l’ >> rpt strip_tac >> gs[getMaxAbsLb_def] + >> rename1 ‘getMaxAbsLb p (iv1::ivs)’ + >> PairCases_on ‘iv1’ >> rename1 ‘getMaxAbsLb p ((iv1Lo, iv1Hi)::ivs)’ + >> gs[getMaxAbsLb_def, max_def] + >> cond_cases_tac >> gs[] + >> ‘getMaxAbsLb p ivs < abs (poly p iv1Lo)’ + by (last_x_assum kall_tac >> real_tac) + >> irule EVERY_MONOTONIC + >> qexists_tac ‘λ (u,v). abs (poly p u) ≤ getMaxAbsLb p ivs’ >> gs[] + >> rpt strip_tac >> Cases_on ‘x’ >> gs[] + >> last_x_assum kall_tac >> real_tac +QED + +Theorem validBounds_is_valid: + ∀ zeros iv. + validBounds iv zeros ⇒ + EVERY (λ (u,v). FST iv ≤ u ∧ v ≤ SND iv) zeros +Proof + Induct_on ‘zeros’ >> rpt strip_tac >> gs[validBounds_def] + >> Cases_on ‘h’ >> gs[] +QED + +Theorem validateZerosLeqErr_EVERY: + ∀ err errorp iv zeroList zeros eps. + validateZerosLeqErr errorp iv zeroList err zeros = (Valid, eps) ⇒ + let realZeros = + (findN zeros (λ(u,v). poly (diff errorp) u * poly (diff errorp) v ≤ 0) + zeroList) + in + EVERY (λ (u,v). FST iv ≤ u ∧ v ≤ SND iv ∧ + abs (u - v) ≤ getMaxWidth realZeros ∧ + abs (poly errorp u) ≤ getMaxAbsLb errorp realZeros ) + realZeros +Proof + gs[validateZerosLeqErr_def, isValid_def] + >> rpt gen_tac >> rpt (cond_cases_tac >> gs[]) + >> disch_then kall_tac + >> qmatch_goalsub_abbrev_tac ‘EVERY all_conds_pred realZeros’ + >> ‘all_conds_pred = + λ x. (λ (u,v). FST iv ≤ u ∧ v ≤ SND iv) x ∧ + (λ (u,v). abs (u - v) ≤ getMaxWidth realZeros) x ∧ + (λ (u,v). abs (poly errorp u) ≤ getMaxAbsLb errorp realZeros) x’ + by (unabbrev_all_tac >> gs[FUN_EQ_THM] + >> rpt strip_tac >> Cases_on ‘x’ >> gs[] >> metis_tac[]) + >> pop_assum $ rewrite_tac o single + >> gs[EVERY_CONJ] >> unabbrev_all_tac + >> gs[findN_def] >> cond_cases_tac >> gs[] + >> qmatch_goalsub_abbrev_tac ‘_ ∧ _ ∧ EVERY _ realZeros’ + >> rpt conj_tac + >- ( + imp_res_tac validBounds_is_valid + >> irule EVERY_MONOTONIC + >> qexists_tac ‘λ (u,v). FST iv ≤ u ∧ v ≤ SND iv’ >> gs[]) + >- ( + assume_tac getMaxWidth_is_max + >> irule EVERY_MONOTONIC + >> qexists_tac ‘λ (u,v). abs (u - v) ≤ getMaxWidth realZeros’ + >> gs[]) + >> assume_tac getMaxAbsLb_is_max + >> irule EVERY_MONOTONIC + >> qexists_tac ‘λ (u,v). abs (poly errorp u) ≤ getMaxAbsLb errorp realZeros’ + >> gs[] +QED + +Theorem EVERY_FILTER_TRUE: + ∀ P l. + EVERY P (FILTER P l) +Proof + Induct_on ‘l’ >> gs[] + >> rpt strip_tac + >> cond_cases_tac >> gs[] +QED + +Theorem validateZerosLeqErr_sound: + ∀ derivative errorp iv zerosList zeros err eps. + derivative = diff errorp ∧ + {x | FST iv ≤ x ∧ x ≤ SND iv ∧ (poly derivative x = &0)} HAS_SIZE zeros ∧ + validateZerosLeqErr errorp iv zerosList err zeros = (Valid, eps) ⇒ + ∀ x. + FST iv ≤ x ∧ x ≤ SND iv ⇒ + abs(poly errorp x) ≤ err +Proof + rpt strip_tac + >> ‘∀ x. FST iv ≤ x ∧ x ≤ SND iv ⇒ ((λ x. poly errorp x) diffl poly derivative x) x’ + by (rpt strip_tac >> gs[polyTheory.POLY_DIFF]) + >> imp_res_tac validateZerosLeqErr_EVERY + >> qpat_x_assum ‘validateZerosLeqErr _ _ _ _ _ = _’ mp_tac + >> gs[validateZerosLeqErr_def, isValid_def] + >> rpt (cond_cases_tac >> gs[]) + >> disch_then kall_tac + >> pop_assum mp_tac + >> qmatch_goalsub_abbrev_tac ‘computed_ub ≤ err’ + >> strip_tac >> irule REAL_LE_TRANS + >> qexists_tac ‘computed_ub’ >> gs[] + >> unabbrev_all_tac + >> once_rewrite_tac [REAL_MUL_COMM] + >> drule $ GEN_ALL BOUND_THEOREM_INEXACT + >> disch_then $ irule o SIMP_RULE std_ss [BETA_THM] + >> gs[] >> conj_tac + >- ( + rpt strip_tac + >> irule POLY_MONO + >> gs[REAL_LE_MAX, abs] + >> ntac 2 $ pop_assum mp_tac + >> rpt $ pop_assum kall_tac + >> every_case_tac >> real_tac) + >> qexists_tac ‘findN zeros (λ (u,v). poly (diff errorp) u * poly (diff errorp) v ≤ 0) zerosList’ >> gs[] + >> rpt strip_tac + >> irule RECORDERED_ROOTCOUNT + >> qexists_tac ‘FST iv’ >> qexists_tac ‘SND iv’ >> gs[] + >> qexists_tac ‘diff errorp’ >> gs[findN_def] + >> cond_cases_tac >> gs[EVERY_FILTER_TRUE] +QED + +Theorem ivAnnot_is_inp: + ∀ f env g. interpIntv f env = SOME g ⇒ erase g = f +Proof + Induct_on ‘f’ >> simp[Once interpIntv_def] + >> rpt strip_tac >> res_tac + >> rpt VAR_EQ_TAC >> gs[erase_def] +QED + +Theorem checker_soundness: + ∀ cert approxSteps zeros. + checker cert approxSteps zeros = Valid ⇒ + ∀ x. + let iv = SND (HD (cert.iv)); var = FST (HD (cert.iv)) in + FST(iv) ≤ x ∧ x ≤ SND (iv) ⇒ + ∃ r. interp cert.transc [(var,x)] = SOME r ∧ + abs (r - poly cert.poly x) ≤ cert.eps +Proof + rpt gen_tac >> gs[checker_def] + >> cond_cases_tac + >> gs[checker_def, approxPoly_def, + CaseEq"option", CaseEq"prod", CaseEq"checkerDefs$result", CaseEq"transc"] + >> rpt strip_tac >> rpt VAR_EQ_TAC + >> qpat_x_assum ‘_ = Valid’ mp_tac >> cond_cases_tac + >> gs[CaseEq"option", CaseEq"prod", CaseEq"checkerDefs$result", CaseEq"transc"] + >> rpt strip_tac >> rpt VAR_EQ_TAC + (* Step 1: Approximate the transcendental fun with its taylor series *) + >> mp_with_then strip_assume_tac ‘interpIntv _ _ = SOME _’ interpIntv_sound + >> first_assum $ mp_then Any (drule_then mp_tac) approxTransc_sound + >> disch_then $ qspec_then ‘[(FST (HD cert.iv), x)]’ mp_tac + >> impl_tac + >- ( + gs[varsContained_def] >> Cases_on ‘cert.iv’ >> gs[] + >> rpt strip_tac >> gs[FIND_def] >> rpt VAR_EQ_TAC + >> gs[INDEX_FIND_def] >> PairCases_on ‘h’ >> gs[] + >> VAR_EQ_TAC >> gs[]) + >> disch_then strip_assume_tac + >> ‘interp cert.transc [(FST (HD cert.iv), x)] = SOME r1’ + by (imp_res_tac ivAnnot_is_inp >> gs[]) + >> qexists_tac ‘r1’ >> gs[] + >> real_rw ‘r1 - poly cert.poly x = r1 - r2 + (r2 - poly cert.poly x)’ + >> irule REAL_LE_TRANS + >> qexists_tac ‘abs (r1 - r2) + abs (r2 - poly cert.poly x)’ + >> gs[REAL_ABS_TRIANGLE] + >> real_once_rw ‘cert.eps = getAnn errAnn + (cert.eps - getAnn errAnn)’ + >> irule REAL_LE_ADD2 >> gs[] + >> Cases_on ‘validateZerosLeqErr (transp -p cert.poly) (SND (HD cert.iv)) zeros (cert.eps - getAnn errAnn) zeros'’ + >> gs[] >> rpt VAR_EQ_TAC + >> mpx_with_then strip_assume_tac ‘reflectToPoly _ _ = _’ (GEN_ALL reflectSemEquiv) + >> ‘r2 = evalPoly transp x’ by gs[] + >> VAR_EQ_TAC + >> rewrite_tac [GSYM poly_compat, GSYM eval_simps] + >> rewrite_tac [poly_compat] + >> drule numZeros_sound >> disch_then $ drule_then drule + >> strip_tac + >> pop_assum $ mp_then Any mp_tac validateZerosLeqErr_sound + >> disch_then $ qspec_then ‘transp -p cert.poly’ mp_tac + >> simp[] + >> disch_then drule + >> disch_then $ qspec_then ‘x’ mp_tac + >> impl_tac >> gs[] +QED + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/cosDeg3.ml b/floatingPoint/tools/dandelion/cosDeg3.ml new file mode 100644 index 0000000000..dd35a2252c --- /dev/null +++ b/floatingPoint/tools/dandelion/cosDeg3.ml @@ -0,0 +1,3 @@ +#use "hol.ml";; +#use "Examples/sos.ml";; +time PURE_SOS `! x. (&858993459/8589934592):real <= x /\ x <= (&1):real ==> ( ( (&5517561/4294967296) ) + ( ( x * (&-139975391/8589934592) ) + ( ( x pow 2 * (&260655175/4294967296) ) + ( ( x pow 3 * (&-2948059219/34359738368) ) + ( ( x pow 4 * (&1/24) ) + ( x pow 6 * (&-1/720) ) ) ) ) )):real <= (&166557509/676457349120):real`;; \ No newline at end of file diff --git a/floatingPoint/tools/dandelion/cosDeg3.tptp b/floatingPoint/tools/dandelion/cosDeg3.tptp new file mode 100644 index 0000000000..43263d76f6 --- /dev/null +++ b/floatingPoint/tools/dandelion/cosDeg3.tptp @@ -0,0 +1,4 @@ +fof(cosDeg3, conjecture, ! [X] :((X : (= 858993459/8589934592,1=)) => ( +((cos (X) - (( 4289449735/4294967296 ) + ( ( X * 139975391/8589934592 ) + ( ( X^2 * -2408138823/4294967296 ) + ( X^3 * 2948059219/34359738368 ) ) ))) <= 582015/2147483648) & + +(((( 4289449735/4294967296 ) + ( ( X * 139975391/8589934592 ) + ( ( X^2 * -2408138823/4294967296 ) + ( X^3 * 2948059219/34359738368 ) ) )) - cos (X)) <= 582015/2147483648)))). \ No newline at end of file diff --git a/floatingPoint/tools/dandelion/cosDeg3.v b/floatingPoint/tools/dandelion/cosDeg3.v new file mode 100644 index 0000000000..abc8c9551f --- /dev/null +++ b/floatingPoint/tools/dandelion/cosDeg3.v @@ -0,0 +1,15 @@ +Require Import Interval.Tactic. +Require Import Reals. + +Goal +forall (x:R),((858993459/8589934592 <= x <= 1) -> +Rabs (cos (x) - (4289449735 / 4294967296 + +(x * (139975391 / 8589934592) + + (x * x * (-2408138823 / 4294967296) + + x * x * x * (2948059219 / 34359738368))))) + <= + 582015/2147483648)%R. +Proof. +intros. +time interval with (i_bisect x, i_taylor x). +Qed. \ No newline at end of file diff --git a/floatingPoint/tools/dandelion/cosDeg3Script.sml b/floatingPoint/tools/dandelion/cosDeg3Script.sml new file mode 100644 index 0000000000..bcc2c7adba --- /dev/null +++ b/floatingPoint/tools/dandelion/cosDeg3Script.sml @@ -0,0 +1,29 @@ +(* + Simple cosine of degree 3 +*) +open realZeroLib bitArithLib preambleDandelion; + +val _ = new_theory "cosDeg3"; + +val _ = realZeroLib.useBinary := false; + +Definition cos_example_def: + cos_example = + <| + transc := Fun Cos (Var "x") ; +poly := [ + 4289449735 * inv ( 2 pow 32 ); + 139975391 * inv ( 2 pow 33 ); + -2408138823 * inv ( 2 pow 32 ); + 2948059219 * inv ( 2 pow 35 ); + ]; + eps := 582015 * inv (2 pow 31 ); + iv := [ ("x", + ( 858993459 * inv (2 pow 33 ), + 1 * inv (2 pow 0 )))]; + |> +End + +Theorem checkerSucceeds = validateCert cos_example_def “8:num”; + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/drangScript.sml b/floatingPoint/tools/dandelion/drangScript.sml new file mode 100644 index 0000000000..00fe2e7f8a --- /dev/null +++ b/floatingPoint/tools/dandelion/drangScript.sml @@ -0,0 +1,360 @@ +(** + Proofs ported about extrema of real-valued, univariate functions, + ported from the work by Harrison +**) +open bossLib RealArith realTheory polyTheory limTheory; +open renameTheory; +open preambleDandelion; + +val _ = new_theory "drang"; + +(* ------------------------------------------------------------------------- *) +(* General theorem about bounding functions. *) +(* ------------------------------------------------------------------------- *) + +(** HOL-Light compatibility **) +val REAL_MUL_AC = REAL_MUL_ASSOC; +val SPEC = Q.SPEC; +val SPECL = Q.SPECL; +val REAL_ARITH = fn t => REAL_ARITH (Term t); +val SUBGOAL_THEN = fn t => SUBGOAL_THEN (Term t); +val UNDISCH_TAC = fn t => UNDISCH_TAC (Term t); +val EXISTS_TAC = fn t => EXISTS_TAC (Term t); +val GEN_REWRITE_TAC = jrhUtils.GEN_REWR_TAC; +val ASM_CASES_TAC = fn t => ASM_CASES_TAC (Term t); + +Theorem BOUND_THEOREM_POS: + ∀ (f:real->real) f' a b ub. + (∀ x. a ≤ x ∧ x ≤ b ⇒ (f diffl (f' x)) x) ∧ + f a ≤ ub ∧ + f b ≤ ub ∧ + (∀ x. a ≤ x ∧ x ≤ b ∧ (f' x = 0) ⇒ f x ≤ ub) ⇒ + (∀ x. a ≤ x ∧ x ≤ b ⇒ f x ≤ ub) +Proof + rpt gen_tac >> strip_tac >> reverse $ Cases_on `a <= b` + >- ( + rpt gen_tac >> pop_assum mp_tac + >> REAL_ARITH_TAC) + >> ‘∀ x. a ≤ x ∧ x ≤ b ⇒ f contl x’ + by ( + rpt strip_tac >> match_mp_tac DIFF_CONT >> + qexists_tac ‘f' x’ >> gs[]) + >> qspecl_then [‘f’, ‘a’, ‘b’] mp_tac CONT_ATTAINS + >> gs[] >> strip_tac >> VAR_EQ_TAC + >> rename1 ‘a ≤ c’ + >> `f(c:real) <= ub` + by ( + Cases_on ‘a:real = c’ >- gs[] + >> Cases_on `c:real = b` >- gs[] + >> qpat_x_assum ‘a <= c’ mp_tac + >> disch_then $ mp_tac o REWRITE_RULE[REAL_LE_LT] + >> qpat_x_assum ‘c <= b’ mp_tac + >> disch_then $ mp_tac o REWRITE_RULE[REAL_LE_LT] + >> gs[] >> rpt strip_tac + >> qspecl_then [`a`, `b`, `c`] mp_tac INTERVAL_LEMMA + >> gs[] + >> disch_then $ X_CHOOSE_THEN (Term `d:real`) strip_assume_tac + >> ‘f' c = 0’ + by ( + irule DIFF_LMAX + >> EXISTS_TAC ‘f:real->real’ + >> EXISTS_TAC ‘c:real’ >> CONJ_TAC + >- (qexists_tac ‘d’ >> gs[]) + >> first_assum irule >> gs[REAL_LE_LT]) + >> first_x_assum irule >> gs[]) + >> rpt strip_tac >> irule REAL_LE_TRANS >> qexists_tac ‘f c’ + >> conj_tac >> gs[] +QED + +Theorem BOUND_THEOREM_NEG: + ∀ f f' a b ub. + (∀ x. a ≤ x ∧ x ≤ b ⇒ (f diffl (f' x)) x) ∧ + ub ≤ f(a) ∧ + ub ≤ f(b) ∧ + (∀ x. a ≤ x ∧ x ≤ b ∧ (f'(x) = 0) ⇒ ub ≤ f(x)) ⇒ + (∀ x. a ≤ x ∧ x ≤ b ⇒ ub ≤ f(x)) +Proof + rpt strip_tac + >> qspecl_then [‘λ x. - (f x)’, ‘λ x. - (f' x)’] mp_tac BOUND_THEOREM_POS + >> disch_then $ qspecl_then [‘a’, ‘b’, ‘-ub’] mp_tac + >> REWRITE_TAC[REAL_LE_NEG2] + >> gs[] >> impl_tac >> gs[] + >> rpt strip_tac >> irule DIFF_NEG >> gs[] +QED + +Theorem BOUND_THEOREM_EXACT: + ∀ f f' a b ub. + (∀ x. a ≤ x ∧ x ≤ b ⇒ (f diffl (f' x)) x) ∧ + abs(f a) ≤ ub ∧ + abs(f b) ≤ ub ∧ + (∀ x. a ≤ x ∧ x ≤ b ∧ (f'(x) = 0) ⇒ abs(f x) ≤ ub) ⇒ + (∀ x. a ≤ x ∧ x ≤ b ⇒ abs(f x) ≤ ub) +Proof + rpt gen_tac + >> REWRITE_TAC[REAL_ARITH `abs(a) <= b <=> -b <= a /\ a <= b`] + >> REWRITE_TAC[PROVE [] (Term `a ==> b /\ c <=> (a ==> b) /\ (a ==> c)`)] + >> REWRITE_TAC[FORALL_AND_THM] >> STRIP_TAC >> GEN_TAC >> CONJ_TAC + >- ( + MATCH_MP_TAC BOUND_THEOREM_NEG >> ASM_REWRITE_TAC[] >> + EXISTS_TAC `f':real->real` >> ASM_REWRITE_TAC[]) + >> MATCH_MP_TAC BOUND_THEOREM_POS >> ASM_REWRITE_TAC[] + >> EXISTS_TAC `f':real->real` >> ASM_REWRITE_TAC[] +QED + +Theorem BOUND_THEOREM_EXACT_ALT: + ∀ f f' a b ub. + (∀ x. a ≤ x ∧ x ≤ b ⇒ (f diffl (f' x)) x) ∧ + (∀ x. (x = a) ∨ (x = b) ∨ + a < x ∧ x < b ∧ (f'(x) = &0) ⇒ abs(f x) ≤ ub) ⇒ + (∀ x. a ≤ x ∧ x ≤ b ⇒ abs(f x) ≤ ub) +Proof + REPEAT GEN_TAC >> STRIP_TAC + >> MATCH_MP_TAC BOUND_THEOREM_EXACT + >> EXISTS_TAC `f':real->real` + >> ASM_REWRITE_TAC[] >> REPEAT STRIP_TAC + >> FIRST_ASSUM MATCH_MP_TAC >> ASM_REWRITE_TAC[] + >> qpat_x_assum `x <= b` mp_tac >> qpat_x_assum `a <= x` mp_tac + >> REAL_ARITH_TAC +QED + +Theorem lemma[local]: + ∀ l. EVERY P l ∧ EXISTS Q l ⇒ EXISTS (λ x. P x ∧ Q x) l +Proof + Induct_on ‘l’ >> gs[EVERY_DEF, EXISTS_DEF] + >> rpt strip_tac >> gs[EXISTS_DEF] +QED + +Theorem BOUND_THEOREM_INEXACT: + ∀ f f' l a b. + (∀ x. a ≤ x ∧ x ≤ b ⇒ (f diffl f'(x)) x) ∧ + (∀ x. a ≤ x ∧ x ≤ b ⇒ abs(f'(x)) <= B) ∧ + (∀ x. a ≤ x ∧ x ≤ b ∧ (f'(x) = &0) ⇒ + EXISTS (λ (u,v). u ≤ x ∧ x ≤ v) l) ∧ + EVERY (λ (u,v). a ≤ u ∧ v ≤ b ∧ abs(u - v) ≤ e ∧ abs(f u) ≤ ub) l ⇒ + ∀ x. a ≤ x ∧ x ≤ b ⇒ abs(f x) ≤ max (abs (f a)) (max (abs (f b)) (ub + B * e)) +Proof + rpt gen_tac >> strip_tac + >> reverse $ Cases_on ‘a ≤ b’ + >- ( + CCONTR_TAC >> gs[] + >> qpat_x_assum ‘~ (a ≤ b)’ mp_tac + >> gs[] >> irule REAL_LE_TRANS >> qexists_tac ‘x’ >> gs[]) + >> match_mp_tac BOUND_THEOREM_EXACT + >> qexists_tac ‘f'’ >> gs[] + >> simp[SimpL “$==>”, REAL_LE_MAX] + >> X_GEN_TAC “x:real” + >> DISCH_THEN (fn th => ASSUME_TAC th >> MP_TAC th) + >> DISCH_THEN (ANTE_RES_THEN MP_TAC) + >> qpat_x_assum ‘EVERY _ l’ mp_tac + >> rewrite_tac[AND_IMP_INTRO] + >> DISCH_THEN (MP_TAC o MATCH_MP lemma) + >> SPEC_TAC(“l:(real#real)list”,“l:(real#real)list”) + >> Induct >> rewrite_tac[EXISTS_DEF] + >> REWRITE_TAC[PROVE [] “a ∨ b ⇒ c ⇔ (a ⇒ c) ∧ (b ⇒ c)”] + >> gs[FORALL_PROD] + >> MAP_EVERY X_GEN_TAC [“u:real”, “v:real”] >> STRIP_TAC + >> qpat_x_assum ‘abs (f u) ≤ ub’ mp_tac + >> gs[REAL_LE_MAX] + >> ‘abs (f x - f u) ≤ B * e’ suffices_by REAL_ARITH_TAC + >> Cases_on ‘x = u’ + >- ( + ASM_REWRITE_TAC[REAL_SUB_REFL, REAL_ABS_0] + >> MATCH_MP_TAC REAL_LE_MUL >> conj_tac + >- ( + irule REAL_LE_TRANS >> qexists_tac ‘abs (f' x)’ >> conj_tac + >- REAL_ARITH_TAC + >> first_x_assum match_mp_tac >> asm_rewrite_tac[]) + >> irule REAL_LE_TRANS >> qexists_tac ‘abs (u - v)’ + >> gs[]) + >> ‘∃ l z. u < z ∧ z < x ∧ + (f diffl l) z ∧ + (f x - f u = (x - u) * l)’ + by ( + MATCH_MP_TAC MVT >> rpt conj_tac + >- gs[REAL_LT_LE] + >- ( + X_GEN_TAC “y:real” >> strip_tac + >> irule DIFF_CONT + >> qexists_tac ‘f' y’ >> first_x_assum irule + >> MAP_EVERY (fn t => qpat_x_assum t mp_tac) + [‘a ≤ u’, ‘u ≤ y’, ‘y ≤ x’, ‘x ≤ v’, ‘v ≤ b’] + >> REAL_ARITH_TAC) + >> X_GEN_TAC “y:real” >> strip_tac >> REWRITE_TAC[differentiable] + >> qexists_tac `f' y` >> first_x_assum irule + >> MAP_EVERY (fn t => qpat_x_assum t mp_tac) + [‘a ≤ u’, ‘u < y’, ‘y < x’, ‘x ≤ v’, ‘v ≤ b’] + >> REAL_ARITH_TAC) + >> rename [‘(f diffl l1) z’] + >> pop_assum $ rewrite_tac o single + >> rewrite_tac [ABS_MUL] + >> GEN_REWRITE_TAC RAND_CONV [REAL_MUL_SYM] + >> irule REAL_LE_MUL2 >> rewrite_tac[REAL_ABS_POS] >> conj_tac + >- ( + MAP_EVERY (fn t => qpat_x_assum t mp_tac) + [‘u ≤ x’, ‘x ≤ v’, ‘abs (u - v) ≤ e’] + >> REAL_ARITH_TAC) + >> ‘l1 = f' z’ + by ( + irule DIFF_UNIQ + >> qexists_tac `f` >> qexists_tac `z:real` + >> gs[] >> first_x_assum irule + >> MAP_EVERY (fn t => qpat_x_assum t mp_tac) + [‘a ≤ u’, ‘u < z’, ‘z < x’, ‘x ≤ b’] + >> REAL_ARITH_TAC) + >> VAR_EQ_TAC >> first_x_assum irule + >> MAP_EVERY (fn t => qpat_x_assum t mp_tac) + [‘a ≤ u’, ‘u < z’, ‘z < x’, ‘x ≤ b’] + >> REAL_ARITH_TAC +QED + +Definition recordered_def: + recordered (a:real) [] b = (a ≤ b) ∧ + recordered a (h::t) b = + (a < FST h ∧ FST h ≤ SND h ∧ recordered (SND h) t b) +End + +Theorem RECORDERED_CLAUSES = + map (SIMP_CONV std_ss [recordered_def]) + [“recordered a [] b”, “recordered a ((u,v)::t) b”] + |> LIST_CONJ + +Theorem RECORDERED_MONO: + ∀ l a a' b. + a ≤ a' ∧ + recordered a' l b ⇒ + recordered a l b +Proof + Induct_on ‘l’ >> gs[recordered_def] + >- (rpt strip_tac >> real_tac) + >> rpt strip_tac >> irule REAL_LET_TRANS + >> qexists_tac ‘a'’ >> gs[] +QED + +Theorem FINITE_AD_HOC_LEMMA: + ∀ a b n. + (a INTER b = EMPTY) ∧ + (∃ x. x IN a) ∧ + (a UNION b) HAS_SIZE n ⇒ + ∃ m. m < n ∧ b HAS_SIZE m +Proof + rpt strip_tac >> gs[HAS_SIZE] + >> ‘CARD(a UNION b) + CARD (a INTER b) = CARD a + CARD(b)’ + by gs[CARD_UNION] + >> ‘CARD (a INTER b) = 0’ by gs[] + >> pop_assum $ gs o single + >> ‘~ (a HAS_SIZE 0)’ + by (CCONTR_TAC >> gs[HAS_SIZE_0]) + >> Cases_on ‘CARD a’ >> gs[EXTENSION, HAS_SIZE] +QED + +Theorem RECORDERED_CONTAINED_LEMMA: + ∀ l p a b n. + recordered a l b ∧ + EVERY (λ(u,v). poly p(u) * poly p(v) ≤ 0) l ∧ + {x | a ≤ x ∧ x ≤ b ∧ (poly p x = 0) ∧ + EXISTS (λ (u,v). u ≤ x ∧ x ≤ v) l} HAS_SIZE n ⇒ + LENGTH l ≤ n +Proof + Induct >> gs[LENGTH] >> rpt gen_tac + >> Cases_on ‘h’ >> gs[] + >> rename1 ‘recordered a ((u,v)::l) b’ + >> gs[recordered_def] + >> qmatch_goalsub_abbrev_tac ‘_ ∧ _ ∧ set_zeroes HAS_SIZE _’ + >> `set_zeroes = + {x | a ≤ x ∧ x ≤ b ∧ (poly p x = 0) ∧ u ≤ x ∧ x ≤ v} UNION + {x | a ≤ x ∧ x ≤ b ∧ (poly p x = 0) ∧ + EXISTS (λ (u,v). u ≤ x ∧ x ≤ v) l}` + by ( + unabbrev_all_tac >> gs[EXTENSION, IN_UNION] >> metis_tac[]) + >> pop_assum $ rewrite_tac o single >> unabbrev_all_tac + >> rpt strip_tac + >> Q.ISPECL_THEN [ + `{x | a <= x /\ x <= b /\ (poly p x = &0) /\ u <= x /\ x <= v}`, + `{x | a <= x /\ x <= b /\ (poly p x = &0) /\ EXISTS (λ (u,v). u <= x /\ x <= v) l}`, + `n:num`] mp_tac FINITE_AD_HOC_LEMMA + >> gs[] + >> W((fn t => SUBGOAL_THEN ‘^t’ (fn th => REWRITE_TAC[th])) o funpow 2 lhand o snd) + >- ( + reverse conj_tac + >- ( + MP_TAC(Q.SPECL [`u:real`, `v:real`, `p:real list`] sturmTheory.STURM_NOROOT) + >> gs[real_gt, GSYM REAL_NOT_LE] + >> strip_tac >> qexists_tac ‘x’ >> gs[] >> conj_tac + >> last_x_assum kall_tac + >- real_tac + >> irule REAL_LE_TRANS >> qexists_tac ‘v’ >> gs[] + >> UNDISCH_TAC ‘recordered v l b’ + >> rpt $ pop_assum kall_tac + >> SPEC_TAC (“v:real”, “v:real”) + >> Induct_on ‘l’ >> gs[recordered_def] + >> rpt strip_tac >> gs[] + >> irule REAL_LE_TRANS >> qexists_tac ‘SND h’ >> gs[] + >> last_x_assum kall_tac >> real_tac) + >> rewrite_tac[IN_INTER, EXTENSION] >> strip_tac >> reverse EQ_TAC >- gs[] + >> rpt strip_tac + >> gs[IN_GSPEC_IFF] + >> qpat_x_assum ‘EXISTS _ _’ mp_tac + >> qpat_x_assum `recordered _ _ _` mp_tac + >> qpat_x_assum `x ≤ v` mp_tac + >> rpt $ pop_assum kall_tac + >> SPEC_TAC (“v:real”, “v:real”) + >> SPEC_TAC (“x:real”, “x:real”) + >> Induct_on ‘l’ >> rpt strip_tac >> gs[recordered_def] + >- ( + Cases_on ‘h’ >> gs[] >> ‘x < x’ suffices_by gs[] + >> irule REAL_LET_TRANS >> qexists_tac ‘v’ >> gs[] + >> irule REAL_LTE_TRANS >> qexists_tac ‘q’ >> gs[]) + >> last_x_assum $ qspecl_then [‘x’, ‘SND h’] mp_tac + >> ‘x ≤ SND h’ by real_tac + >> rpt $ disch_then drule + >> gs[combinTheory.o_DEF] + >> irule LIST_EXISTS_MONO + >> qexists_tac ‘λ (u,v). u ≤ x ∧ x ≤ v’ >> gs[]) + >> disch_then $ X_CHOOSE_THEN “m:num” strip_assume_tac + >> irule LESS_OR + >> irule LESS_EQ_LESS_TRANS + >> qexists_tac ‘m’ >> gs[] + >> first_assum irule + >> qexists_tac ‘a’ >> qexists_tac ‘b’ >> qexists_tac ‘p’ >> gs[] + >> irule RECORDERED_MONO + >> qexists_tac ‘v’ >> gs[] + >> last_x_assum kall_tac >> real_tac +QED + +Theorem CARD_SUBSET_LE: + ∀ a b. + FINITE b /\ a SUBSET b /\ (CARD b <= CARD a) ==> (a = b) +Proof + rpt strip_tac + >> ‘CARD a ≤ CARD b’ by metis_tac[CARD_SUBSET] + >> ‘CARD b = CARD a’ by gs[] + >> irule SUBSET_EQ_CARD >> gs[] + >> irule SUBSET_FINITE >> qexists_tac ‘b’ >> gs[] +QED + +Theorem RECORDERED_ROOTCOUNT: + ∀ l a b. + {x | a ≤ x ∧ x ≤ b ∧ (poly p x = &0)} HAS_SIZE (LENGTH l) ∧ + recordered a l b ∧ + EVERY (λ (u,v). poly p(u) * poly p(v) ≤ 0) l ⇒ + ∀ x. a ≤ x ∧ x ≤ b ∧ (poly p(x) = &0) ⇒ + EXISTS (λ (u,v). u ≤ x ∧ x ≤ v) l +Proof + rpt gen_tac >> disch_tac + >> gs[PROVE[] “(a ==> b) <=> (a /\ b <=> a)”] + >> ‘{x | a <= x /\ x <= b /\ (poly p x = &0) /\ + EXISTS (λ (u,v). u <= x /\ x <= v) l} = + {x | a <= x /\ x <= b /\ (poly p x = &0)}’ + by ( + last_x_assum $ strip_assume_tac o REWRITE_RULE[HAS_SIZE] + >> irule CARD_SUBSET_LE >> rpt $ reverse conj_tac >> gs[] + >- gs[SUBSET_DEF] + >> irule RECORDERED_CONTAINED_LEMMA + >> qexists_tac ‘a’ >> qexists_tac ‘b’ >> qexists_tac ‘p’ >> gs[HAS_SIZE] + >> irule SUBSET_FINITE + >> qexists_tac `{x | a <= x /\ x <= b /\ (poly p x = &0)}` + >> gs[SUBSET_DEF]) + >> gs[EXTENSION] >> metis_tac[] +QED + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/euclidDivScript.sml b/floatingPoint/tools/dandelion/euclidDivScript.sml new file mode 100644 index 0000000000..ee1c290d8b --- /dev/null +++ b/floatingPoint/tools/dandelion/euclidDivScript.sml @@ -0,0 +1,183 @@ +(** + Computable version of polynomial division and a correctness proof. + Inspired by the implementation in Isabelle/HOL + isabelle.in.tum.de/library/HOL/HOL-Computational_Algebra/Polynomial.html + used to implement a computable version of Sturm sequences +**) +open pred_setTheory listTheory bossLib RealArith realTheory polyTheory; +open realPolyTheory sturmTheory realPolyProofsTheory; +open renameTheory; +open bitArithLib; +open preambleDandelion; + +val _ = new_theory "euclidDiv"; + +(** Definition of polynomial division, following Isabelle/HOL's definition in + HOL/Computational_Algebra/Polynomial.thy. + **) +Definition divmod_aux_def: + divmod_aux lc q r d (dr:num) 0 = (q,r) ∧ + divmod_aux lc q r d dr (SUC n) = + let rr = lc *c r; + qq = coeff r dr; + rrr = rr -p ((monom n [qq]) *p d); + qqq = (lc *c q) +p (monom n [qq]) in + divmod_aux lc qqq rrr d (dr-1) n +End + +Definition divmod_def: + divmod (p: poly) (q: poly) = + if (q = []) then ([], p) + else divmod_aux (coeff q (deg q)) [] p q (deg p) (1 + (deg p) - (deg q)) +End + +(* Define quotient as the first projection of the tuple *) +Definition quo_def: + quo (p:poly) (q:poly) = FST (divmod p q) +End + +(* Define remainder as the second projection of the tuple *) +Definition rm_def: + rm (p:poly) (q:poly) = SND (divmod p q) +End + +Theorem divmod_aux_correct: + ∀ lc q r d dr n q' r'. + divmod_aux lc q r d dr n = (q',r') ∧ + d ≠ [] ∧ lc = coeff d (deg d) ∧ deg r ≤ dr ∧ + (n = 1 + dr - deg d ∨ dr = 0 ∧ n = 0 ∧ zerop r ) ⇒ + (zerop r' ∨ deg r' < deg d) ∧ + evalPoly ((lc pow n) *c (d *p q +p r)) = evalPoly (d *p q' +p r') +Proof + Induct_on ‘n’ + >- (rpt strip_tac >> gs[divmod_aux_def, mul_cst1, zerop_def, reduce_preserving]) + >> rpt gen_tac >> simp[Once divmod_aux_def] + >> qmatch_goalsub_abbrev_tac ‘divmod_aux lc _ (rr -p monom _ [ qq ] *p _) _ _ _ = _’ + >> qmatch_goalsub_abbrev_tac ‘divmod_aux lc _ (_ -p b *p _) _ _ _ = _’ + >> qmatch_goalsub_abbrev_tac ‘divmod_aux lc qqq rrr _ _ _ = _’ + >> rpt $ disch_then strip_assume_tac + >> ‘dr = n + deg d’ by gs[] + >> ‘coeff (b *p d) dr = coeff b n * coeff d (deg d)’ + by ( + Cases_on ‘qq = 0’ >> rpt VAR_EQ_TAC + >- (unabbrev_all_tac >> gs[monom_n, monom_0_mul, coeff_empty]) + >> ‘n = deg b’ + by (gs[Abbr‘b’] >> irule $ GSYM deg_monom_eq >> gs[]) + >> VAR_EQ_TAC >> gs [coeff_mult_degree_sum]) + >> ‘coeff (b *p d) dr = lc * coeff b n’ by (rpt VAR_EQ_TAC >> gs[REAL_MUL_COMM]) + >> ‘coeff rr dr = lc * coeff r dr’ by gs[Abbr‘rr’, coeff_cst_mul] + >> ‘coeff rrr dr = 0’ + by ( + rpt VAR_EQ_TAC + >> gs[Abbr‘rrr’, Abbr‘qq’, Abbr‘b’, poly_sub_def, poly_neg_def, coeff_add, + coeff_cst_mul, monom_n] + >> REAL_ARITH_TAC) + >> ‘deg (lc *c r) ≤ dr’ + by ( + irule LESS_EQ_TRANS >> qexists_tac ‘deg r’ + >> gs[deg_leq_mul_cst]) + >> ‘deg (b *p d) ≤ dr’ + by ( + VAR_EQ_TAC >> gs[Abbr‘rrr’, Abbr‘b’] + >> irule LESS_EQ_TRANS + >> qexists_tac ‘if zerop (monom n [qq]) ∨ zerop d then 0 + else deg (monom n [qq]) + deg d’ + >> gs[deg_mul_poly] + >> cond_cases_tac >> gs[] + >> Cases_on ‘qq = 0’ >> gs[] + >- ( + ‘deg (monom n [0]) ≤ n’ suffices_by gs[] + >> gs[deg_monom_0]) + >> gs[deg_monom_eq]) + >> ‘deg rrr ≤ dr - 1’ + by (VAR_EQ_TAC >> irule coeff_0_degree_minus_1 >> gs[Abbr ‘rrr’] + >> irule LESS_EQ_TRANS + >> qexists_tac ‘n + deg d’ + >> reverse conj_tac >- gs[] + >> irule LESS_EQ_TRANS + >> qexists_tac ‘MAX (deg rr) (deg (b *p d))’ + >> conj_tac + >- irule deg_sub_poly + >> gs[]) + >> first_x_assum $ + qspecl_then [‘lc’, ‘qqq’, ‘rrr’, ‘d’, ‘dr - 1’, ‘q'’, ‘r'’] mp_tac + >> impl_tac + >- ( + gs[] >> reverse $ Cases_on ‘dr’ >- gs[] + >> ‘n = 0’ by gs[] >> ‘deg d = 0’ by (rpt VAR_EQ_TAC >> gs[]) + >> ‘deg rrr = 0’ by (ntac 2 $ pop_assum kall_tac >> gs[]) + >> DISJ2_TAC >> fs[] + >> irule deg_coeff_zerop >> gs[]) + >> rpt $ disch_then assume_tac + >> conj_tac >- gs[] + >> pop_assum (fn th => assume_tac $ CONJUNCT2 th) + >> pop_assum $ rewrite_tac o single o GSYM + >> rpt VAR_EQ_TAC + >> gs[] + >> unabbrev_all_tac + >> gs[FUN_EQ_THM, eval_simps] + >> rpt gen_tac + >> qmatch_goalsub_abbrev_tac ‘_ = lc pow _ * ( _ * (_ * _ + mnm) + _)’ + >> ‘evalPoly d x * (lc * evalPoly q x + mnm) = + lc * (evalPoly d x * evalPoly q x) + evalPoly d x * mnm’ + by real_tac + >> pop_assum $ rewrite_tac o single + >> rewrite_tac [GSYM REAL_ADD_ASSOC] + >> ‘evalPoly d x * mnm + (lc * evalPoly r x - evalPoly d x * mnm) = + lc * evalPoly r x’ by real_tac + >> pop_assum $ rewrite_tac o single + >> rewrite_tac [GSYM REAL_LDISTRIB] + >> rewrite_tac [REAL_MUL_ASSOC] + >> ‘lc pow (n + 1) = lc pow n * lc’ suffices_by gs[] + >> gs[GSYM ADD1, pow] +QED + +Theorem divmod_correct: + ~ zerop g ∧ + divmod f g = (q,r) ⇒ + evalPoly ((coeff g (deg g) pow (SUC (deg f) - deg g)) *c f) = evalPoly (g *p q +p r) ∧ + (zerop r ∨ deg r < deg g) +Proof + simp[divmod_def] >> rpt $ disch_then strip_assume_tac + >> ‘g ≠ []’ by (Cases_on ‘g’ >> gs[zerop_def, reduce_def]) + >> gs[] + >> drule divmod_aux_correct >> gs[] >> strip_tac + >> gs[mul_0_right, poly_add_rid, poly_mul_cst_reduce, ADD1] +QED + +Theorem divmod_coeff_1: + ~zerop g ∧ coeff g (deg g) = 1 ∧ + divmod f g = (q,r) ⇒ + evalPoly f = evalPoly (g *p q +p r) ∧ + (zerop r ∨ deg r < deg g) +Proof + rpt strip_tac >> drule divmod_correct + >> disch_then drule + >> strip_tac + >> gs[FUN_EQ_THM, eval_simps] +QED + +Theorem divmod_coeff_1_reduce: + c ≠ 0 ∧ + ~zerop (c *c g) ∧ coeff (c *c g) (deg (c *c g)) = 1 ∧ + divmod (c *c f) (c *c g) = (q,r) ⇒ + evalPoly f = evalPoly (g *p q +p (inv c *c r)) ∧ + (zerop r ∨ deg r < deg (c *c g)) +Proof + rpt strip_tac + >> first_assum $ mp_then Any mp_tac divmod_coeff_1 + >> impl_tac >> gs[deg_of_const_mul] + >> gs[FUN_EQ_THM, eval_simps] + >> rpt strip_tac + >> ‘evalPoly f x = inv c * (c * evalPoly f x)’ by + (‘evalPoly f x = 1 * evalPoly f x’ by real_tac + >> pop_assum $ once_rewrite_tac o single + >> ‘1 = inv c * c’ by gs[REAL_MUL_LINV] + >> pop_assum $ once_rewrite_tac o single + >> gs[]) + >> pop_assum $ once_rewrite_tac o single + >> first_x_assum $ qspec_then ‘x’ $ once_rewrite_tac o single + >> gs[REAL_LDISTRIB] +QED + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/floverConnScript.sml b/floatingPoint/tools/dandelion/floverConnScript.sml new file mode 100644 index 0000000000..266c6721e7 --- /dev/null +++ b/floatingPoint/tools/dandelion/floverConnScript.sml @@ -0,0 +1,72 @@ +(** + Connection to FloVer roundoff error analyzer, currently unused +**) + +open ExpressionsTheory ExpressionSemanticsTheory realPolyTheory +open preambleDandelion; + +val _ = new_theory "floverConn"; + +Definition poly2FloVer_def: + poly2FloVer []:real expr = Const REAL 0 ∧ + poly2FloVer (c1::cs) = Binop Plus (Const REAL c1) (Binop Mult (Var 0) (poly2FloVer cs)) +End + +Theorem polyEval_implies_FloVer_eval: + ∀ (p:poly) (x:real) (r:real). + evalPoly p x = r ⇒ + eval_expr (λ v:num. if v = 0 then SOME x else NONE) (λ e:real expr. SOME REAL) (poly2FloVer p) r REAL +Proof + Induct_on ‘p’ >> gs[evalPoly_def, eval_expr_rules, poly2FloVer_def] + >> rpt strip_tac + >- ( + irule Const_dist' >> gs[] + >> qexists_tac ‘0’ >> gs[perturb_def, MachineTypeTheory.mTypeToR_pos]) + >> irule Binop_dist' + >> qexists_tac ‘0’ >> gs[perturb_def, MachineTypeTheory.mTypeToR_pos, MachineTypeTheory.isJoin_def] + >> ntac 2 $ qexists_tac ‘REAL’ + >> qexists_tac ‘h’ >> qexists_tac ‘x * evalPoly p x’ + >> gs[evalBinop_def, MachineTypeTheory.isFixedPoint_def, MachineTypeTheory.join_fl_def] + >> conj_tac + >- ( + irule Const_dist' >> gs[] + >> qexists_tac ‘0’ >> gs[perturb_def, MachineTypeTheory.mTypeToR_pos]) + >> irule Binop_dist' + >> qexists_tac ‘0’ >> gs[perturb_def, MachineTypeTheory.mTypeToR_pos, MachineTypeTheory.isJoin_def] + >> ntac 2 $ qexists_tac ‘REAL’ + >> qexists_tac ‘x’ >> qexists_tac ‘evalPoly p x’ + >> gs[evalBinop_def, MachineTypeTheory.isFixedPoint_def, MachineTypeTheory.join_fl_def] + >> irule Var_load >> gs[] +QED + +Theorem FloVer_eval_real_typed: + ∀ p r x m. + eval_expr (λ v:num. if v = 0 then SOME x else NONE) (λ e. SOME REAL) (poly2FloVer p) r m ⇒ + m = REAL +Proof + Induct_on `p` \\ rpt strip_tac \\ gs[poly2FloVer_def, Once eval_expr_cases] +QED + +Theorem FloVer_eval_implies_polyEval: + ∀ p x r. + eval_expr (λ v:num. if v = 0 then SOME x else NONE) (λ e. SOME REAL) (poly2FloVer p) r REAL ⇒ + evalPoly p x = r +Proof + Induct_on ‘p’ >> gs[evalPoly_def, eval_expr_cases, poly2FloVer_def] + >> rpt strip_tac + >- gs[perturb_def] + >> qpat_x_assum `r = _` $ gs o single + >> gs[perturb_def] + >> imp_res_tac FloVer_eval_real_typed >> gs[] + >> res_tac >> gs[evalBinop_def] +QED + +Theorem evalPoly_Flover_eval_bisim: + ∀ p x r. + evalPoly p x = r ⇔ + eval_expr (λ v:num. if v = 0 then SOME x else NONE) (λ e. SOME REAL) (poly2FloVer p) r REAL +Proof + rpt strip_tac >> EQ_TAC >> gs[FloVer_eval_implies_polyEval, polyEval_implies_FloVer_eval] +QED + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/mcLaurinApproxScript.sml b/floatingPoint/tools/dandelion/mcLaurinApproxScript.sml new file mode 100644 index 0000000000..bea01bb11d --- /dev/null +++ b/floatingPoint/tools/dandelion/mcLaurinApproxScript.sml @@ -0,0 +1,2012 @@ +(*** + Proofs of McLaurin series for the supported elementary functions + described in transcLang file +**) + +open moreRealTheory realPolyTheory realPolyProofsTheory; +open preambleDandelion; + +val _ = new_theory "mcLaurinApprox"; + +val _ = realLib.deprecate_real(); + +Theorem SUCC_minus_1[local]: + ∀ m. 0 < m ⇒ (SUC m DIV 2) = (m - 1) DIV 2 + 1 +Proof + rpt gen_tac + >> ‘0 < m ⇒ SUC m = (m - 1) + 2’ by gs[] + >> strip_tac >> res_tac + >> pop_assum $ rewrite_tac o single + >> gs[ADD_DIV_RWT] +QED + +Theorem minus_1_div_2[local]: + ∀ m. 0 < m ⇒ -1 pow (SUC m DIV 2) = - ( -1 pow ((m - 1) DIV 2)) +Proof + rpt strip_tac >> gs[SUCC_minus_1, REAL_POW_ADD] +QED + +Theorem plus_1_div_2[local]: + ∀ m. 0 < m ⇒ -1 pow (SUC (SUC m) DIV 2) = - (-1 pow (m DIV 2)) +Proof + rpt strip_tac + >> ‘SUC (SUC m) = m + 2’ by gs[] + >> pop_assum $ rewrite_tac o single + >> gs[ADD_DIV_RWT, REAL_POW_ADD] +QED + +Theorem MCLAURIN_SIN_LE: + ∀ x n. + ∃ t. + abs(t) ≤ abs (x) ∧ + (\n. if EVEN n then + (sin x = + sum(0,n) + (λm. + inv (&FACT m) * x pow m * + if EVEN m then sin 0 * -1 pow (m DIV 2) + else cos 0 * -1 pow ((m - 1) DIV 2)) + + inv (&FACT n) * sin t * x pow n * -1 pow (n DIV 2)) + else + (sin x = + sum (0,n) + (λm. + inv (&FACT m) * x pow m * + if EVEN m then sin 0 * -1 pow (m DIV 2) + else cos 0 * -1 pow ((m - 1) DIV 2)) + + cos t * inv (&FACT n) * x pow n * + -1 pow ((n - 1) DIV 2))) n +Proof + rpt strip_tac + >> assume_tac MCLAURIN_ALL_LE + >> pop_assum $ qspec_then ‘sin’ assume_tac + >> pop_assum $ qspec_then ‘\n x. if EVEN n then (((-1) pow (n DIV 2)) * sin x) + else (((-1) pow ((n-1) DIV 2)) * cos x)’ + assume_tac + >> ‘(λn x. + if EVEN n then -1 pow (n DIV 2) * sin x + else -1 pow ((n - 1) DIV 2) * cos x) 0 = + sin /\ + (!m x. + ((λn x. + if EVEN n then -1 pow (n DIV 2) * sin x + else -1 pow ((n - 1) DIV 2) * cos x) m diffl + (λn x. + if EVEN n then -1 pow (n DIV 2) * sin x + else -1 pow ((n - 1) DIV 2) * cos x) (SUC m) x) x)’ by + ( conj_tac + >- ( BETA_TAC >> gs[FUN_EQ_THM] ) + >> rpt strip_tac + >> BETA_TAC + >> Cases_on ‘m=0’ + >- ( gs[EVEN] >> ‘(λx. sin x) = sin’ by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> gs[ DIFF_SIN] + ) + >> Cases_on ‘EVEN m’ + >- ( gs[EVEN] + >> ‘(λx. sin x * -1 pow (m DIV 2)) = (λx. -1 pow (m DIV 2) * sin x)’ + by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> ‘(cos x * -1 pow (m DIV 2)) = ( -1 pow (m DIV 2) * cos x)’ by + gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> irule limTheory.DIFF_CMUL + >> gs[DIFF_SIN] + ) + >> gs[EVEN] + >> ‘(λx. cos x * -1 pow ((m - 1) DIV 2)) = + (λx. -1 pow ((m - 1) DIV 2) * cos x)’ by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> ‘(sin x * -1 pow (SUC m DIV 2)) = ( -1 pow (SUC m DIV 2) * sin x)’ + by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >>‘-1 pow (SUC m DIV 2) = - (-1 pow ((m - 1) DIV 2))’ by + ( irule minus_1_div_2 >> gs[] ) + >> pop_assum $ rewrite_tac o single + >> ‘(-(-1 pow ((m - 1) DIV 2)) * sin x) = + ((-1 pow ((m - 1) DIV 2)) *(- sin x))’ by gs[] + >> pop_assum $ rewrite_tac o single + >> irule limTheory.DIFF_CMUL + >> gs[DIFF_COS] + ) + >> res_tac + >> pop_assum mp_tac + >> DISCH_THEN (fn th => REPEAT GEN_TAC THEN STRIP_ASSUME_TAC (SPEC_ALL th)) + >> qexists_tac ‘t’ + >> gs[] +QED + +Theorem MCLAURIN_COS_LE: + ∀ x n. + ∃ t. + abs(t) <= abs (x) ∧ + (\n. if EVEN n then + (cos x = sum(0,n) + (λm. + (&FACT m)⁻¹ * x pow m * + if EVEN m then cos 0 * -1 pow (m DIV 2) + else sin 0 * -1 pow ((SUC m) DIV 2)) + + (&FACT n)⁻¹ * cos t * x pow n * -1 pow (n DIV 2)) + else + (cos x = sum (0,n) + (λm. + (&FACT m)⁻¹ * x pow m * + if EVEN m then cos 0 * -1 pow (m DIV 2) + else sin 0 * -1 pow ((SUC m) DIV 2)) + + sin t * (&FACT n)⁻¹ * x pow n * + -1 pow ((SUC n) DIV 2))) n +Proof + rpt strip_tac + >> assume_tac MCLAURIN_ALL_LE + >> pop_assum $ qspec_then ‘cos’ assume_tac + >> pop_assum $ qspec_then ‘\n x. if EVEN n then (((-1) pow (n DIV 2)) * cos x) + else (((-1) pow ((SUC n) DIV 2)) * sin x)’ + assume_tac + >> ‘(λn x. + if EVEN n then -1 pow (n DIV 2) * cos x + else -1 pow (SUC n DIV 2) * sin x) 0 = + cos /\ + (!m x. + ((λn x. + if EVEN n then -1 pow (n DIV 2) * cos x + else -1 pow (SUC n DIV 2) * sin x) m diffl + (λn x. + if EVEN n then -1 pow (n DIV 2) * cos x + else -1 pow (SUC n DIV 2) * sin x) (SUC m) x) x)’ by + ( conj_tac + >- ( BETA_TAC >> gs[FUN_EQ_THM] ) + >> rpt strip_tac + >> BETA_TAC + >> Cases_on ‘m=0’ + >- ( gs[EVEN] >> ‘(λx. cos x) = cos’ by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> gs[DIFF_COS] + ) + >> Cases_on ‘EVEN m’ + >- ( gs[EVEN] + >> ‘(λx. cos x * -1 pow (m DIV 2)) = (λx. -1 pow (m DIV 2) * cos x)’ + by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >>‘-1 pow (SUC (SUC m) DIV 2) = - (-1 pow (m DIV 2))’ + by gs[plus_1_div_2] + >> pop_assum $ rewrite_tac o single + >> ‘(sin x * -(-1 pow (m DIV 2))) = (-1 pow (m DIV 2) * - sin x)’ + by gs[] + >> pop_assum $ rewrite_tac o single + >> irule limTheory.DIFF_CMUL + >> gs[DIFF_COS] + ) + >> gs[EVEN] + >> ‘(λx. sin x * -1 pow (SUC m DIV 2)) = + (λx. -1 pow (SUC m DIV 2) * sin x )’ by gs[] + >> pop_assum $ rewrite_tac o single + >> ‘(cos x * -1 pow (SUC m DIV 2)) = + (-1 pow (SUC m DIV 2)) * cos x’ by gs[] + >> pop_assum $ rewrite_tac o single + >> irule limTheory.DIFF_CMUL + >> gs[DIFF_SIN] + ) + >> res_tac + >> pop_assum mp_tac + >> DISCH_THEN (fn th => REPEAT GEN_TAC THEN STRIP_ASSUME_TAC (SPEC_ALL th)) + >> qexists_tac ‘t’ + >> gs[] +QED + +(*** Prove lemma for bound on exp in the interval, x IN [0, 0.5] +based on John Harrison's paper **) +Theorem REAL_EXP_BOUND_LEMMA: + ! x. + &0 <= x /\ x <= inv 2 ==> + exp(x) <= &1 + &2 * x +Proof + rpt strip_tac >> irule REAL_LE_TRANS + >> qexists_tac ‘suminf (λ n. x pow n)’ >> conj_tac + >- ( + gs[exp] >> irule seqTheory.SER_LE + >> gs[seqTheory.summable] >> rpt conj_tac + >- ( + rpt strip_tac + >> jrhUtils.GEN_REWR_TAC RAND_CONV [GSYM REAL_MUL_LID] + >> irule REAL_LE_RMUL_IMP >> gs[POW_POS] + >> irule REAL_INV_LE_1 + >> gs[REAL_OF_NUM_LE, LESS_EQ_IFF_LESS_SUC] + >> ‘1 = SUC 0’ by gs[] + >> pop_assum $ rewrite_tac o single + >> gs[LESS_MONO_EQ, FACT_LESS]) + >- (qexists_tac ‘exp x’ >> gs[BETA_RULE EXP_CONVERGES] ) + >> qexists_tac ‘inv (1 - x)’ + >> irule seqTheory.GP + >> gs[abs] >> irule REAL_LET_TRANS >> qexists_tac ‘inv 2’ + >> conj_tac >> gs[]) + >> ‘suminf (λ n. x pow n) = inv (1 - x)’ + by ( + irule $ GSYM seqTheory.SUM_UNIQ + >> irule seqTheory.GP + >> gs[abs] >> irule REAL_LET_TRANS >> qexists_tac ‘inv 2’ + >> conj_tac >> gs[]) + >> pop_assum $ rewrite_tac o single + >> irule REAL_LE_RCANCEL_IMP + >> qexists_tac ‘1 - x’ + >> ‘1 - x <> 0’ by (CCONTR_TAC >> gs[]) + >> simp[REAL_MUL_LINV] + >> conj_tac + >- ( + irule REAL_LET_TRANS >> qexists_tac ‘inv 2 - x’ + >> rewrite_tac[REAL_ARITH “&0 <= x:real - y <=> y <= x”] + >> rewrite_tac[REAL_ARITH “a - x < b - x <=> a < b:real”] + >> gs[]) + >> gs[REAL_SUB_LDISTRIB, REAL_ADD_LDISTRIB] + >> rewrite_tac[POW_2, + REAL_ARITH “&1 <= &1 + &2 * x:real - (x + &2 * (x * x)) <=> + x * (&2 * x) <= x * &1”] + >> irule REAL_LE_LMUL_IMP >> gs[] + >> irule REAL_LE_RCANCEL_IMP >> qexists_tac ‘inv 2’ + >> rewrite_tac[REAL_MUL_LID, REAL_ARITH “2 * x * inv 2 = x:real * (2 * inv 2)”] + >> gs[REAL_MUL_RINV] +QED + +Theorem REAL_EXP_MINUS1_BOUND_LEMMA: + !x. &0 <= x /\ x <= inv(&2) ==> &1 - exp(-x) <= &2 * x +Proof + REPEAT STRIP_TAC >> REWRITE_TAC[REAL_LE_SUB_RADD] + >> ONCE_REWRITE_TAC[REAL_ADD_SYM] + >> REWRITE_TAC[GSYM REAL_LE_SUB_RADD] + >> irule REAL_LE_RCANCEL_IMP + >> EXISTS_TAC “exp(x)” + >> REWRITE_TAC[REAL_ADD_LINV, EXP_0, EXP_POS_LT] + >> MATCH_MP_TAC REAL_LE_TRANS + >> EXISTS_TAC “(&1 - &2 * (x:real)) * (&1 + &2 * x)” + >> CONJ_TAC + >- ( irule REAL_LE_LMUL_IMP >> reverse conj_tac + >- ( REWRITE_TAC[REAL_LE_SUB_LADD, REAL_ADD_LID] + >> MATCH_MP_TAC REAL_LE_TRANS + >> EXISTS_TAC “&2 * inv(&2)” + >> reverse CONJ_TAC + >- gs[] + >> irule REAL_LE_LMUL_IMP >> gs[] + ) + >> MATCH_MP_TAC REAL_EXP_BOUND_LEMMA >> gs[] + ) + >> ONCE_REWRITE_TAC[REAL_MUL_SYM] + >> REWRITE_TAC[REAL_DIFFSQ] + >> REWRITE_TAC[REAL_MUL_LID, REAL_LE_SUB_RADD, EXP_NEG_MUL] + >> REWRITE_TAC[REAL_LE_ADDR] + >> MATCH_MP_TAC REAL_LE_MUL >> REWRITE_TAC[] + >> MATCH_MP_TAC REAL_LE_MUL >> gs[] +QED + +(** Mclaurin series for sqrt fucntion **) +(** Idea is to convert the sqrt function to exp (ln x /2) **) +Theorem SQRT_EXPLN_DIFF: + !x. 0 <= x ==> ((λx. exp ((\x. (ln (1+x)) / &2) x)) diffl + (exp ((\x. (ln (1+x)) / &2) x) * (inv (1+x) / &2))) x +Proof + rpt strip_tac >> irule DIFF_COMPOSITE_EXP + >> ‘(λx. ln (1+x) / 2) = (λx. (1/ &2) * (ln (1+x)))’ by + ( gs[FUN_EQ_THM]) + >> pop_assum $ rewrite_tac o single + >> ‘((1+x)⁻¹ / 2) = (1/ &2) * (inv (1+x))’ by gs[] + >> pop_assum $ rewrite_tac o single + >> ‘(λx. 1 / 2 * ln (1 + x)) = (λx. 1 / 2 * ((\x. ln (1 + x)) x))’ by + ( gs[FUN_EQ_THM]) + >> pop_assum $ rewrite_tac o single + >> irule limTheory.DIFF_CMUL + >> ‘(1 + x)⁻¹ = ((\x. (1 + x)) x)⁻¹ * &1’ by gs[] + >> pop_assum $ once_rewrite_tac o single + >> ‘(λx. ln (1 + x)) = (λx. ln ((\x. (1 + x)) x))’ by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> irule DIFF_LN_COMPOSITE + >> rpt conj_tac + >- ( gs[] >> ‘&1+x = x+ &1 ’ by REAL_ARITH_TAC + >> pop_assum $ rewrite_tac o single + >> gs[REAL_LET_ADD] + ) + >> gs[diff_chain] +QED + +Theorem SQRT_EXPLN_GENERAL: + !x. 0 < x ==> sqrt (x) = exp ((\x. (ln (x)) / &2) x) +Proof + rpt strip_tac >> gs[sqrt] + >> ‘2 = SUC 1’ by gs[] + >> pop_assum $ rewrite_tac o single + >> irule ROOT_LN >> gs[] +QED + +Theorem SQRT_EXPLN: + !x. 0 <= x ==> sqrt (1+x) = exp ((\x. (ln (1+x)) / &2) x) +Proof + rpt strip_tac >> gs[sqrt] + >> ‘2 = SUC 1’ by gs[] + >> pop_assum $ rewrite_tac o single + >> irule ROOT_LN + >> ‘&1 + x = x + &1’ by REAL_ARITH_TAC + >> pop_assum $ rewrite_tac o single + >> gs[REAL_LET_ADD] +QED + +Theorem exp_add_EXPLN: + ! m t. m <> 0 ==> 0 <= t ==> + exp (ln (1 + t) * &(2 * m + 1) / &2) = + exp (ln (1 + t)) * exp ((ln (1 + t) * &(2 * PRE m + 1) / &2)) +Proof + rpt strip_tac + >> ‘ exp (ln (1 + t)) * exp (ln (1 + t) * &(2 * PRE m + 1) / &2) = + exp ((ln (1 + t)) + (ln (1 + t) * &(2 * PRE m + 1) / &2))’ by + ( ABBREV_TAC “x = ln (1 + t) ” + >> ‘ &(2 * PRE m + 1) / 2 = &(2 * PRE m + 1) * inv(&2)’ by gs[] + >> ‘x * &(2 * PRE m + 1) / 2 = x * &(2 * PRE m + 1) * inv(&2) ’ + by gs[] + >> pop_assum $ rewrite_tac o single + >> ‘exp (x + x * &(2 * PRE m + 1) * 2⁻¹) = + exp x * exp (x * &(2 * PRE m + 1) * 2⁻¹)’ by + ( ABBREV_TAC “y = x * &(2 * PRE m + 1) * 2⁻¹” + >> rw[transcTheory.EXP_ADD] + ) + >> gs[] + ) + >> pop_assum $ rewrite_tac o single + >> ‘(ln (1 + t) * &(2 * m + 1) / &2) = + (ln (1 + t) + (ln (1 + t) * &(2 * PRE m + 1) / &2)) ’ by + ( ‘ ln (1 + t) * &(2 * PRE m + 1) / 2 = + ln (1 + t) *( &(2 * PRE m + 1) * inv(&2))’ by gs[] + >> pop_assum $ rewrite_tac o single + >> ‘ln (1 + t) + ln (1 + t) * (&(2 * PRE m + 1) * 2⁻¹) = + ln (1 + t) * &1 + ln (1 + t) * (&(2 * PRE m + 1) * 2⁻¹)’ by gs[] + >> pop_assum $ rewrite_tac o single + >> ‘ln (1 + t) * 1 + ln (1 + t) * (&(2 * PRE m + 1) * 2⁻¹) = + ln (1 + t) * (1 + (&(2 * PRE m + 1) * 2⁻¹))’ by gs[GSYM REAL_LDISTRIB] + >> pop_assum $ rewrite_tac o single + >> gs[] + >> DISJ2_TAC + >> ‘ 1 / &2 = inv(&2)’ by gs[GSYM REAL_INV_1OVER] + >> pop_assum $ rewrite_tac o single + >> gs[REAL_LDISTRIB] + ) + >> pop_assum $ once_rewrite_tac o single + >> gs[] +QED + +Theorem sqrt_mth_derivative: + !m t. + m <> 0 ==> 0 <= t ==> + ((λx. (exp (ln (1 + x) * &(2 * PRE m + 1) / 2))⁻¹) diffl + (-1 / 2 * ((exp (ln (1 + t) * &(2 * m + 1) / 2))⁻¹ * &(2 * m - 1)))) + t +Proof + rpt strip_tac + >> ‘(λx. (exp (ln (1 + x) * &(2 * PRE m + 1) / 2))⁻¹) = + (λx. (exp (- (ln (1 + x) * &(2 * PRE m + 1) / 2))))’ by + ( gs[FUN_EQ_THM, EXP_NEG] ) + >> pop_assum $ rewrite_tac o single + >> ‘(λx. exp (-(ln (1 + x) * &(2 * PRE m + 1) / 2))) = + (λx. exp ( (\x. (-(ln (1 + x) * &(2 * PRE m + 1) / 2))) x))’ by + gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> ‘(-1 / 2 * ((exp (ln (1 + t) * &(2 * m + 1) / 2))⁻¹ * &(2 * m - 1))) = + exp ( (\x. (-(ln (1 + x) * &(2 * PRE m + 1) / 2))) t) * (&(2 * PRE m + 1) + / &2 * - inv (1+t))’ by + ( gs[] + >> ‘ (exp (ln (1 + t) * &(2 * m + 1) / 2))⁻¹ = + (exp (- ((ln (1 + t) * &(2 * m + 1) / 2))))’ by gs[EXP_NEG] + >> pop_assum $ rewrite_tac o single + >> ‘(1 + t)⁻¹ = exp (- (ln (1+t)))’ by + ( ‘- ln (1 + t) = ln (inv (1+t))’ by + ( ‘0 < &1 + t’ by + ( ‘&1+t = t+ &1 ’ by REAL_ARITH_TAC + >> pop_assum $ rewrite_tac o single + >> gs[REAL_LET_ADD] + ) + >> gs[LN_INV] + ) + >> pop_assum $ rewrite_tac o single + >> gs[EXP_LN] + >>‘&1+t = t+ &1 ’ by REAL_ARITH_TAC + >> pop_assum $ rewrite_tac o single + >> gs[REAL_LET_ADD] + ) + >> pop_assum $ rewrite_tac o single + >> ‘ exp (-(ln (1 + t) * &(2 * PRE m + 1)) / 2) * &(2 * PRE m + 1) * + exp (-ln (1 + t)) = + ( exp (-(ln (1 + t) * &(2 * PRE m + 1)) / 2) * exp (-ln (1 + t))) * + &(2 * PRE m + 1)’ by gs[] + >> pop_assum $ rewrite_tac o single + >> ‘&(2 * m - 1) = &(2 * PRE m + 1)’ by gs[] + >> ‘ exp (-(ln (1 + t) * &(2 * m + 1) / 2)) = + ( exp (-(ln (1 + t) * &(2 * PRE m + 1) / 2)) * exp (-ln (1 + t)))’ + by ( gs[EXP_NEG] >> gs[GSYM REAL_INV_MUL'] + >> gs[exp_add_EXPLN] + ) + >> gs[] + ) + >> pop_assum $ rewrite_tac o single + >> irule DIFF_COMPOSITE_EXP + >> ‘(λx. -(ln (1 + x) * &(2 * PRE m + 1) / 2)) = + (λx. (-(&(2 * PRE m + 1) / 2)) *((\x. ln (1+x)) x))’ by + ( gs[FUN_EQ_THM] ) + >> pop_assum $ rewrite_tac o single + >> ‘ (&(2 * PRE m + 1) / 2 * -(1 + t)⁻¹) = + (-(&(2 * PRE m + 1) / 2)) * (1 + t)⁻¹’ by gs[] + >> pop_assum $ rewrite_tac o single + >> irule limTheory.DIFF_CMUL + >> ‘(λx. ln (1 + x)) = (λx. ln ((\x. (1 + x)) x))’ by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> ‘(1 + t)⁻¹ = (((\x . (1 + x)) t)⁻¹) * &1 ’ by gs[] + >> pop_assum $ once_rewrite_tac o single + >> irule DIFF_LN_COMPOSITE + >> conj_tac + >- ( gs[] >> ‘&1+t = t+ &1 ’ by REAL_ARITH_TAC + >> pop_assum $ rewrite_tac o single + >> gs[REAL_LET_ADD] + ) + >> gs[diff_chain] +QED + +Theorem SQRT_DIFF_m_not_0: + ! m x t. 0 <= t ==> m <> 0 ==> + ((λx'. + (exp (ln (1 + x') * &(2 * PRE m + 1) / 2))⁻¹ * + &FACT (2 * PRE m) * (&FACT (m - 1))⁻¹ * -1 pow (m - 1) * + (2 pow m)⁻¹ * (2 pow (m - 1))⁻¹) diffl + ((exp (ln (1 + t) * &(2 * m + 1) / 2))⁻¹ * (&FACT m)⁻¹ * + &FACT (2 * m) * -1 pow m * (2 pow m)⁻¹ * (2 pow SUC m)⁻¹)) t +Proof + rpt strip_tac + >> ‘(λx'. + (exp (ln (1 + x') * &(2 * PRE m + 1) / 2))⁻¹ * + &FACT (2 * PRE m) * (&FACT (m - 1))⁻¹ * -1 pow (m - 1) * + (2 pow m)⁻¹ * (2 pow (m - 1))⁻¹) = + (λx'. + -1 pow (m - 1) * ((\x. ((exp (ln (1 + x) * &(2 * PRE m + 1) / 2))⁻¹ * + &FACT (2 * PRE m) * (&FACT (m - 1))⁻¹ * + (2 pow m)⁻¹ * (2 pow (m - 1))⁻¹)) x'))’ by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> ‘-1 pow m = -1 pow (m-1) * -1 pow 1’ by + ( ‘m = (m-1) + 1’ by gs[] + >> ‘-1 pow m = -1 pow ((m-1) + 1)’ by gs[] + >> pop_assum $ rewrite_tac o single + >> gs[REAL_POW_ADD] + ) + >> pop_assum $ rewrite_tac o single + >> ‘ ((exp (ln (1 + t) * &(2 * m + 1) / 2))⁻¹ * (&FACT m)⁻¹ * + &FACT (2 * m) * (-1 pow (m - 1) * -1 pow 1) * (2 pow m)⁻¹ * + (2 pow SUC m)⁻¹) = + -1 pow (m - 1) * ((exp (ln (1 + t) * &(2 * m + 1) / 2))⁻¹ * (&FACT m)⁻¹ * + &FACT (2 * m) * -1 pow 1 * (2 pow m)⁻¹ * + (2 pow SUC m)⁻¹)’ by gs[] + >> pop_assum $ rewrite_tac o single + >> irule limTheory.DIFF_CMUL + >> ‘inv (&FACT m) = inv (&FACT (m-1)) * inv (&m)’ by + ( ‘FACT m = m * FACT(m-1)’ by + ( ‘m = SUC (m-1)’ by gs[] + >> pop_assum $ once_rewrite_tac o single + >> ‘FACT (SUC (m - 1) - 1) = FACT (m - 1)’ by gs[] + >> pop_assum $ rewrite_tac o single + >> gs[FACT] + ) + >> pop_assum $ rewrite_tac o single + >> once_rewrite_tac[GSYM REAL_OF_NUM_MUL] + >> gs[REAL_INV_MUL'] + ) + >> pop_assum $ rewrite_tac o single + >> ‘(λx. + (exp (ln (1 + x) * &(2 * PRE m + 1) / 2))⁻¹ * + &FACT (2 * PRE m) * (&FACT (m - 1))⁻¹ * (2 pow m)⁻¹ * + (2 pow (m - 1))⁻¹) = + (λx. + (&FACT (m - 1))⁻¹ * ((\x. (exp (ln (1 + x) * &(2 * PRE m + 1) / 2))⁻¹ * + &FACT (2 * PRE m) * (2 pow m)⁻¹ * + (2 pow (m - 1))⁻¹) x))’ by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> ‘ ((exp (ln (1 + t) * &(2 * m + 1) / 2))⁻¹ * + ((&FACT (m - 1))⁻¹ * (&m)⁻¹) * &FACT (2 * m) * -1 pow 1 * + (2 pow m)⁻¹ * (2 pow SUC m)⁻¹) = + ((&FACT (m - 1))⁻¹ * (((exp (ln (1 + t) * &(2 * m + 1) / 2))⁻¹ * + (&m)⁻¹) * &FACT (2 * m) * -1 pow 1 * + (2 pow m)⁻¹ * (2 pow SUC m)⁻¹))’ by gs[] + >> pop_assum $ rewrite_tac o single + >> irule limTheory.DIFF_CMUL + >> ‘(λx. + (exp (ln (1 + x) * &(2 * PRE m + 1) / 2))⁻¹ * + &FACT (2 * PRE m) * (2 pow m)⁻¹ * (2 pow (m - 1))⁻¹) = + (λx. + (2 pow m)⁻¹ * ((\x. (exp (ln (1 + x) * &(2 * PRE m + 1) / 2))⁻¹ * + &FACT (2 * PRE m) * (2 pow (m - 1))⁻¹) x))’ + by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> ‘ ((exp (ln (1 + t) * &(2 * m + 1) / 2))⁻¹ * (&m)⁻¹ * &FACT (2 * m) * + -1 pow 1 * (2 pow m)⁻¹ * (2 pow SUC m)⁻¹) = + (2 pow m)⁻¹ * + (((exp (ln (1 + t) * &(2 * m + 1) / 2))⁻¹ * (&m)⁻¹ * &FACT (2 * m) * + -1 pow 1 * (2 pow SUC m)⁻¹))’ by gs[] + >> pop_assum $ rewrite_tac o single + >> irule limTheory.DIFF_CMUL + >> ‘2 pow (SUC m) = 2 pow (m-1) * 2 pow 2’ by + ( ‘SUC m = (m-1) + 2’ by gs[] + >> pop_assum $ rewrite_tac o single + >> gs[REAL_POW_ADD] + ) + >> pop_assum $ rewrite_tac o single + >> ‘(λx. + (exp (ln (1 + x) * &(2 * PRE m + 1) / 2))⁻¹ * + &FACT (2 * PRE m) * (2 pow (m - 1))⁻¹) = + (λx. + (2 pow (m - 1))⁻¹ * ((\x. (exp (ln (1 + x) * &(2 * PRE m + 1) / 2))⁻¹ * + &FACT (2 * PRE m)) x)) ’ by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> ‘(2 pow (m - 1) * 2²)⁻¹ = (2 pow (m - 1))⁻¹ * inv (2²)’ by + gs[REAL_INV_MUL'] + >> pop_assum $ rewrite_tac o single + >> ‘ ((exp (ln (1 + t) * &(2 * m + 1) / 2))⁻¹ * (&m)⁻¹ * &FACT (2 * m) * + -1 pow 1 * ((2 pow (m - 1))⁻¹ * 2² ⁻¹)) = + (2 pow (m - 1))⁻¹ * + ((exp (ln (1 + t) * &(2 * m + 1) / 2))⁻¹ * (&m)⁻¹ * &FACT (2 * m) * + -1 pow 1 * inv (2²))’ by REAL_ARITH_TAC + >> pop_assum $ rewrite_tac o single + >> irule limTheory.DIFF_CMUL + >> ‘ &FACT (2 * m) = &(2 * m) * &(2 * m - 1) * &FACT (2 * PRE m) ’ by + ( ‘&FACT (2 * m) = &(2 * m) * &FACT(2 * m - 1)’ by + ( ‘&FACT (2 * m) = &FACT (SUC (2* m - 1))’ by + ( ‘(2 * m) = (SUC (2* m - 1))’ by gs[] + >> pop_assum $ once_rewrite_tac o single + >> ‘(SUC (SUC (2 * m - 1) - 1)) = (SUC (2 * m - 1))’ by gs[] + >> gs[] + ) + >> ‘ &(2 * m) = &(SUC (2 * m - 1))’ by gs[] + >> pop_assum $ rewrite_tac o single + >> gs[FACT] + ) + >> pop_assum $ rewrite_tac o single + >> ‘ &FACT (2 * m - 1) = &(2 * m - 1) * &FACT (2 * PRE m)’ by + ( ‘(2 * m - 1) = SUC (2 * PRE m)’ by gs[] + >> pop_assum $ rewrite_tac o single + >> gs[FACT] + ) + >> gs[] + ) + >> ‘((exp (ln (1 + t) * &(2 * m + 1) / 2))⁻¹ * (&m)⁻¹ * &FACT (2 * m) * + -1 pow 1 * 2² ⁻¹) = + &FACT (2 * PRE m) * + ((exp (ln (1 + t) * &(2 * m + 1) / 2))⁻¹ * (&m)⁻¹ * &(2 * m) * + &(2 * m - 1) * -1 pow 1 * 2² ⁻¹)’ by gs[] + >> pop_assum $ rewrite_tac o single + >> ‘(λx. (exp (ln (1 + x) * &(2 * PRE m + 1) / 2))⁻¹ * &FACT (2 * PRE m)) = + (λx. &FACT (2 * PRE m) *( (\x. + (exp (ln (1 + x) * &(2 * PRE m + 1) / 2))⁻¹ ) x)) ’ + by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> irule limTheory.DIFF_CMUL + >> ‘ &(2 * m) = &2 * &m ’ by gs[GSYM REAL_OF_NUM_MUL] + >> ‘ ((exp (ln (1 + t) * &(2 * m + 1) / 2))⁻¹ * (&m)⁻¹ * &(2 * m) * + &(2 * m - 1) * -1 pow 1 * 2² ⁻¹) = + ((exp (ln (1 + t) * &(2 * m + 1) / 2))⁻¹ * ((&m)⁻¹ * &m) * &2 * + &(2 * m - 1) * -1 pow 1 * 2² ⁻¹)’ by gs[] + >> pop_assum $ rewrite_tac o single + >> gs[] + >> pop_assum $ kall_tac + >> gs[sqrt_mth_derivative] +QED + +Theorem MCLAURTIN_SQRT_LE: + ! x n. 0 < x ==> + ?t. (0 < t ∧ t ≤ x) /\ + (\n. exp ((\x. (ln (1+x)) / &2) x) = sum (0,n) + (λm. + (λm x. + if m = 0 then exp ((\x. (ln (1+x)) / &2) x) + else + -1 pow (m - 1) * &FACT (2 * PRE m) * + (exp ((\x. &(2 * PRE m + 1) * (ln (1+x)) / &2) x))⁻¹ + * (2 pow m)⁻¹ * + (2 pow (m - 1))⁻¹ * (&FACT (m - 1))⁻¹) m 0 / + &FACT m * x pow m) + + (λm x. + if m = 0 then exp ((\x. (ln (1+x)) / &2) x) + else + -1 pow (m - 1) * &FACT (2 * PRE m) * + (exp ((\x. &(2 * PRE m + 1) * (ln (1+x)) / &2) x))⁻¹ + * (2 pow m)⁻¹ * + (2 pow (m - 1))⁻¹ * (&FACT (m - 1))⁻¹) n t / &FACT n * + x pow n) n +Proof + rpt strip_tac + >> assume_tac MCLAURIN + >> pop_assum $ qspec_then ‘(\x. exp ((\x. (ln (1+x)) / &2) x))’ assume_tac + >> pop_assum $ qspec_then ‘ \m x. + if m = 0 then exp ((\x. (ln (1+x)) / &2) x) + else + -1 pow (m - 1) * &FACT (2 * PRE m) * + (exp ((\x. &(2 * PRE m + 1) * (ln (1+x)) / &2) x))⁻¹ + * (2 pow m)⁻¹ * + (2 pow (m - 1))⁻¹ * (&FACT (m - 1))⁻¹’ + assume_tac + >> pop_assum $ qspecl_then [‘x’, ‘n’] assume_tac + >> ‘n= 0:num \/ (0- ( gs[sum] >> qexists_tac ‘x’ >> gs[FACT] ) + >> gs[] + >> ‘(!m t. + m < n /\ 0 <= t /\ t <= x ==> + ((λx'. + if m = 0 then exp (ln (1 + x') / 2) + else + (exp (ln (1 + x') * &(2 * PRE m + 1) / 2))⁻¹ * + &FACT (2 * PRE m) * (&FACT (m - 1))⁻¹ * -1 pow (m - 1) * + (2 pow m)⁻¹ * (2 pow (m - 1))⁻¹) diffl + ((exp (ln (1 + t) * &(2 * m + 1) / 2))⁻¹ * (&FACT m)⁻¹ * + &FACT (2 * m) * -1 pow m * (2 pow m)⁻¹ * (2 pow SUC m)⁻¹)) t)’ by + ( rpt strip_tac + >> Cases_on ‘m=0’ + >- ( gs[FACT] + >> ‘ (1 / 2 * (exp (ln (1 + t) / 2))⁻¹) = + (exp ((\x. (ln (1+x)) / &2) t) * (inv (1+t) / &2)) ’ by + ( gs[] >> DISJ2_TAC + >> gs[GSYM EXP_N] + >> ‘exp (ln (1 + t)) = (1+t)’ by + ( gs[EXP_LN] >> ‘&1 + t = t + &1’ by REAL_ARITH_TAC + >> pop_assum $ rewrite_tac o single + >> gs[REAL_LET_ADD] + ) + >> pop_assum $ rewrite_tac o single + >> ‘(1 + t) * (1 + t)⁻¹ = (1 + t)⁻¹ * (1 + t)’ by REAL_ARITH_TAC + >> pop_assum $ rewrite_tac o single + >> irule REAL_MUL_LINV + >> ‘&0 < 1 + t ==> 1 + t <> &0’ by REAL_ARITH_TAC + >> first_x_assum irule + >> ‘&1 + t = t + &1’ by REAL_ARITH_TAC + >> pop_assum $ rewrite_tac o single + >> gs[REAL_LET_ADD] + ) + >> pop_assum $ rewrite_tac o single + >> ‘(λx'. exp (ln (1 + x') / 2)) = + (λx'. exp ((λx. ln (1 + x) / 2) x'))’ by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> gs[SQRT_EXPLN_DIFF] + ) + >> gs[SQRT_DIFF_m_not_0] + ) + >> res_tac + >> qexists_tac ‘t’ + >> rpt conj_tac + >- gs[] + >- gs[REAL_LT_IMP_LE] + >> gs[] +QED + + + +(** Mclaurin approximation for tangent function. The idea is to + to write tan x = sin x / cos x. We know the series + expansion of sin. We need to figure out series expansion of + inverse function. and then multiply the two series expansion + **) + +(* McLaurin series for the inverse function : 1/ (1-x) *) +Theorem EXP_inv_intermed: + 0 ≤ t ∧ t < 1 ⇒ + ((λx'. exp (-ln (1 − x'))) diffl (exp (-2 * ln (1 − t)) * &FACT 1)) t +Proof + rpt strip_tac + >> ‘(exp (-2 * ln (1 - t)) * &FACT 1) = exp (-2 * ln (1 - t))’ + by ( gs[FACT] >> DISJ2_TAC >> EVAL_TAC) + >> pop_assum $ rewrite_tac o single + >> ‘exp (-2 * ln (1 - t)) = + exp ((\x. -(ln (1-x))) t) * ( exp (- ln (1-t)))’ by + ( gs[] + >> ‘-2 * ln (1 - t) = &2 * (-ln(1-t))’ by gs[] + >> pop_assum $ rewrite_tac o single + >> gs[EXP_N] + ) + >> pop_assum $ rewrite_tac o single + >> ‘(λx. exp (-ln (1 - x))) = (\x. exp ((\x. -(ln (1-x))) x))’ by + gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> irule DIFF_COMPOSITE_EXP + >> ‘exp (-ln (1 - t)) = inv (1-t)’ by + ( ‘ ln (inv (1-t)) = - ln(1-t)’ by + ( irule LN_INV + >> ‘0+t < 1 ==> 0 < 1 - t’ by gs[REAL_LT_ADD_SUB] + >> first_assum irule + >> gs[] + ) + >> ‘-ln (1 - t) = ln (1 - t)⁻¹ ’ by gs[] + >> pop_assum $ rewrite_tac o single + >> gs[EXP_LN] + >> ‘0+t < 1 ==> 0 < 1 - t’ by gs[REAL_LT_ADD_SUB] + >> first_assum irule + >> gs[] + ) + >> pop_assum $ rewrite_tac o single + >> ‘(λx. -ln (1 - x)) = (λx. (-1) * ((\x. ln (1 - x)) x))’ by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> ‘(1 - t)⁻¹ = (-1) * (-(1 - t)⁻¹)’ by gs[] + >> pop_assum $ once_rewrite_tac o single + >> irule limTheory.DIFF_CMUL + >> ‘(λx. ln (1 - x)) = (λx. ln ((\x. (1 - x)) x))’ by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> ‘-(1 - t)⁻¹ = (((\x . (1 - x)) t)⁻¹) * -1 ’ by gs[] + >> pop_assum $ once_rewrite_tac o single + >> irule DIFF_LN_COMPOSITE + >> conj_tac + >- ( gs[] >> ‘0+t < 1 ==> 0 < 1 - t’ by gs[REAL_LT_ADD_SUB] + >> first_assum irule + >> gs[] + ) + >> gs[diff_chain_sub] +QED + +Theorem EXP_inv_intermed_m_neq_0: + m ≠ 0 ∧ 0 ≤ t ∧ t < 1 ⇒ + ((λx'. exp (-ln (1 - x') * &SUC m) * &FACT m) diffl + (exp (-ln (1 - t) * &SUC (SUC m)) * &FACT (SUC m))) t +Proof + rpt strip_tac + >> ‘(λx'. exp (-ln (1 - x') * &SUC m) * &FACT m) = + (λx'. &FACT m * ((\x. exp (-ln (1 - x) * &SUC m)) x'))’ by + gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> ‘(exp (-ln (1 - t) * &SUC (SUC m)) * &FACT (SUC m)) = + &FACT m * (exp (-ln (1 - t) * &SUC (SUC m)) * &(SUC m))’ by + ( ‘&FACT (SUC m) = &(SUC m) * &FACT m’ by gs[FACT] + >> gs[] + ) + >> pop_assum $ rewrite_tac o single + >> irule limTheory.DIFF_CMUL + >> ‘exp (-ln (1 - t) * &SUC (SUC m)) = + exp (-ln (1 - t) * &SUC m) * exp (-ln (1-t))’ by ( + ‘exp (-ln (1 - t)) = exp (-ln (1 - t) * &1)’ by gs[] + >> pop_assum $ rewrite_tac o single + >> ‘ exp (-ln (1 - t) * &SUC m) * exp (-ln (1 - t) * 1) = + exp ((-ln (1 - t) * &SUC m) + (-ln (1 - t) * 1))’ + by gs[transcTheory.EXP_ADD] + >> pop_assum $ rewrite_tac o single + >> ‘(-ln (1 - t) * &SUC (SUC m)) = + (-ln (1 - t) * &SUC m + -ln (1 - t) * 1) ’ by ( + ‘(-ln (1 - t) * &SUC m + -ln (1 - t) * 1) = + (-ln (1 - t) * (&SUC m + 1))’ + by gs[GSYM REAL_LDISTRIB] + >> pop_assum $ rewrite_tac o single + >> ‘&(SUC (SUC m)) = &SUC m + 1’ suffices_by gs[] + >> gs[integerTheory.INT]) + >> pop_assum $ rewrite_tac o single) + >> pop_assum $ rewrite_tac o single + >> ‘(λx. exp (-ln (1 - x) * &SUC m)) = + (λx. exp ((\x. (-ln (1 - x) * &SUC m)) x))’ by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> ‘exp (-ln (1 - t) * &SUC m) = exp ((λx. -ln (1 - x) * &SUC m) t)’ + by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> ‘(exp ((λx. -ln (1 - x) * &SUC m) t) * exp (-ln (1 - t)) * &SUC m) = + (exp ((λx. -ln (1 - x) * &SUC m) t) * (exp (-ln (1 - t)) * &SUC m))’ by + gs[] + >> pop_assum $ rewrite_tac o single + >> irule DIFF_COMPOSITE_EXP + >> ‘(λx. -ln (1 - x) * &SUC m) = (λx. &SUC m * ((\x. -ln (1 - x)) x))’ by + gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> ‘(exp (-ln (1 - t)) * &SUC m) = &(SUC m) * exp (-ln (1 - t))’ by gs[] + >> pop_assum $ rewrite_tac o single + >> irule limTheory.DIFF_CMUL + >> ‘exp (-ln (1 - t)) = inv (1-t)’ by + ( ‘ ln (inv (1-t)) = - ln(1-t)’ by + ( irule LN_INV + >> ‘0+t < 1 ==> 0 < 1 - t’ by gs[REAL_LT_ADD_SUB] + >> first_assum irule + >> gs[] + ) + >> ‘-ln (1 - t) = ln (1 - t)⁻¹ ’ by gs[] + >> pop_assum $ rewrite_tac o single + >> gs[EXP_LN] + >> ‘0+t < 1 ==> 0 < 1 - t’ by gs[REAL_LT_ADD_SUB] + >> first_assum irule + >> gs[] + ) + >> pop_assum $ rewrite_tac o single + >> ‘(λx. -ln (1 - x)) = (λx. (-1) * ((\x. ln (1 - x)) x))’ by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> ‘(1 - t)⁻¹ = (-1) * (-(1 - t)⁻¹)’ by gs[] + >> pop_assum $ once_rewrite_tac o single + >> irule limTheory.DIFF_CMUL + >> ‘(λx. ln (1 - x)) = (λx. ln ((\x. (1 - x)) x))’ by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> ‘-(1 - t)⁻¹ = (((\x . (1 - x)) t)⁻¹) * -1 ’ by gs[] + >> pop_assum $ once_rewrite_tac o single + >> irule DIFF_LN_COMPOSITE + >> conj_tac + >- ( gs[] >> ‘0+t < 1 ==> 0 < 1 - t’ by gs[REAL_LT_ADD_SUB] + >> first_assum irule + >> gs[] + ) + >> gs[diff_chain_sub] +QED + +Theorem MCLAURIN_INV: + ∀ x n. + 0 < x ∧ x < 1 ⇒ + ∃ t. + 0 < t ∧ t ≤ x ∧ + (λ n. + exp ((λ x. -(ln (1 - x))) x) = + sum (0,n) (λm. + inv (&FACT m) * x pow m * + if m = 0 then exp (-ln 1) + else exp (-ln 1 * &SUC m) * &FACT m) + + inv (&FACT n) * x pow n * + (if n = 0 then exp (-ln (1 - t)) + else exp (-ln (1 - t) * &SUC n) * &FACT n)) n +Proof + rpt strip_tac + >> assume_tac MCLAURIN + >> pop_assum $ qspec_then ‘(\x. exp ((\x. -(ln (1-x))) x))’ + assume_tac + >> pop_assum $ qspec_then ‘ \m x. + if m = 0 then exp ((\x. -(ln (1-x))) x) + else + &(FACT m) * + (exp ((\x. - &(SUC m) * ln(1-x) ) x))’ + assume_tac + >> pop_assum $ qspecl_then [‘x’, ‘n’] assume_tac + >> ‘n= 0:num \/ (0- ( gs[sum] >> qexists_tac ‘x’ >> gs[FACT] ) + >> gs[] + >> ‘ (!m t. + m < n /\ 0 <= t /\ t <= x ==> + ((λx'. + if m = 0 then exp (-ln (1 - x')) + else exp (-ln (1 - x') * &SUC m) * &FACT m) diffl + (exp (-ln (1 - t) * &SUC (SUC m)) * &FACT (SUC m))) t)’ by + ( rpt strip_tac + >> Cases_on ‘m=0’ + >- ( gs[] + >> ‘ t < 1 ’ by + ( UNDISCH_TAC “x:real < &1” >> UNDISCH_TAC “t:real <= x” + >> REAL_ARITH_TAC + ) + >> gs[EXP_inv_intermed] + ) + >> gs[] + >> ‘ t < 1 ’ by + ( UNDISCH_TAC “x:real < &1” >> UNDISCH_TAC “t:real <= x” + >> REAL_ARITH_TAC + ) + >> gs[EXP_inv_intermed_m_neq_0] + ) + >> res_tac + >> qexists_tac ‘t’ + >> rpt conj_tac + >- gs[] + >- ( UNDISCH_TAC “t < (x:real)” >> REAL_ARITH_TAC ) + >> gs[] +QED + +Theorem MCLAURIN_COS_INV: + ∀ x n. + 0 < x ∧ x < (pi / &2) ⇒ + ∃ t. + 0 < t ∧ t ≤ x ∧ + inv (cos x) = + sum (0,n) + (λm. + inv (&FACT m) * (1-cos x) pow m * + if m = 0 then exp (-ln 1) + else exp (-ln 1 * &SUC m) * &FACT m) + + inv (&FACT n) * (1 - cos x) pow n * + (if n = 0 then (inv (cos t)) + else (inv(cos t) pow &SUC n) * &FACT n) +Proof + rpt strip_tac + >> assume_tac MCLAURIN_INV + >> pop_assum $ qspecl_then [‘1- cos x’, ‘n’] assume_tac + >> ‘ 0 < 1 - cos x /\ 1 - cos x < 1’ by + ( conj_tac + >- ( ‘cos x < 1 ==> 0 < 1 - cos x’ by REAL_ARITH_TAC + >> first_assum irule + >> gs[cos_lt_1] + ) + >> ‘0 < cos x ==> 1 - cos x < 1’ by REAL_ARITH_TAC + >> first_assum irule + >> irule COS_POS_PI + >> gs[] >> irule REAL_LT_TRANS >> qexists_tac ‘0’ + >> gs[PI_POS] + ) + >> res_tac + >> qexists_tac ‘acs (1-t)’ + >> rpt conj_tac + >- ( assume_tac ACS_BOUNDS_LT + >> pop_assum $ qspec_then ‘1-t’ assume_tac + >> ‘-1 < 1 - t /\ 1 - t < 1’ by + ( conj_tac + >- ( ‘t < &2 ==> -1 < 1 - t’ by REAL_ARITH_TAC + >> first_assum irule + >> irule REAL_LET_TRANS + >> qexists_tac ‘1 - cos x’ + >> conj_tac + >- ( ‘- 1 < cos x ==> 1 - cos x < 2’ by REAL_ARITH_TAC + >> first_assum irule + >> irule REAL_LT_TRANS + >> qexists_tac ‘0:real’ + >> conj_tac + >- gs[] + >> gs[COS_POS_PI2] + ) + >> gs[] + ) + >> UNDISCH_TAC “(0:real) < t” >> REAL_ARITH_TAC + ) + >> gs[] + ) + >- ( irule cos_decreasing + >> rpt conj_tac + >- ( irule REAL_LT_TRANS + >> qexists_tac ‘pi / &2’ + >> conj_tac + >- gs[] + >> gs[PI2_lt_PI] ) + >- ( assume_tac ACS_BOUNDS_LT + >> pop_assum $ qspec_then ‘1-t’ assume_tac + >> ‘-1 < 1 - t /\ 1 - t < 1’ by + ( conj_tac + >- ( ‘t < &2 ==> -1 < 1 - t’ by REAL_ARITH_TAC + >> first_assum irule + >> irule REAL_LET_TRANS + >> qexists_tac ‘1 - cos x’ + >> conj_tac + >- ( ‘- 1 < cos x ==> 1 - cos x < 2’ by REAL_ARITH_TAC + >> first_assum irule + >> irule REAL_LT_TRANS + >> qexists_tac ‘0:real’ + >> conj_tac + >- gs[] + >> gs[COS_POS_PI2] + ) + >> gs[] + ) + >> UNDISCH_TAC “(0:real) < t” >> REAL_ARITH_TAC + ) + >> gs[] ) + >- gs[] + >- ( + assume_tac ACS_BOUNDS_LT + >> pop_assum $ qspec_then ‘1-t’ assume_tac + >> ‘-1 < 1 - t /\ 1 - t < 1’ by + ( conj_tac + >- ( ‘t < &2 ==> -1 < 1 - t’ by REAL_ARITH_TAC + >> first_assum irule + >> irule REAL_LET_TRANS + >> qexists_tac ‘1 - cos x’ + >> conj_tac + >- ( ‘- 1 < cos x ==> 1 - cos x < 2’ by REAL_ARITH_TAC + >> first_assum irule + >> irule REAL_LT_TRANS + >> qexists_tac ‘0:real’ + >> conj_tac + >- gs[] + >> gs[COS_POS_PI2]) + >> gs[] ) + >> UNDISCH_TAC “(0:real) < t” >> REAL_ARITH_TAC ) + >> gs[] ) + >> ‘(cos (acs (1 - t))) = 1-t’ by + ( irule ACS_COS + >> conj_tac + >- ( ‘0 <= t ==> 1 - t <= 1’ by REAL_ARITH_TAC + >> first_assum irule + >> UNDISCH_TAC “(0:real) < t” + >> REAL_ARITH_TAC + ) + >> ‘t <= 2 ==> -1 <= 1 - t’ by REAL_ARITH_TAC + >> first_assum irule + >> irule REAL_LE_TRANS + >> qexists_tac ‘1 - cos x’ + >> conj_tac + >- gs[] + >> irule REAL_LT_IMP_LE + >>‘- 1 < cos x ==> 1 - cos x < 2’ by REAL_ARITH_TAC + >> first_assum irule + >> irule REAL_LT_TRANS + >> qexists_tac ‘0:real’ + >> conj_tac + >- gs[] + >> gs[COS_POS_PI2] + ) + >> pop_assum $ rewrite_tac o single + >> UNDISCH_TAC “t <= 1 - cos x” + >> REAL_ARITH_TAC ) + >> pop_assum kall_tac + >> pop_assum kall_tac + >> pop_assum kall_tac + >> ‘(cos x)⁻¹ = exp ((λx. -ln (1 - x)) (1 - cos x))’ by + ( ‘(λx. -ln (1 - x)) (1 - cos x) = -ln (cos x)’ by + ( ‘ (λx. -ln (1 - x)) (1 - cos x) = -ln (1 - (1 - cos x))’ by gs[] + >> pop_assum $ rewrite_tac o single + >> ‘(1 - (1 - cos x)) = cos x’ by REAL_ARITH_TAC + >> gs[] + ) + >> pop_assum $ rewrite_tac o single + >> ‘ln (inv (cos x)) = -ln(cos x)’ by + ( irule LN_INV >> irule COS_POS_PI + >> gs[] >> irule REAL_LT_TRANS >> qexists_tac ‘0’ + >> gs[PI_POS] + ) + >> ‘-ln (cos x) = ln (inv (cos x))’ by gs[] + >> pop_assum $ rewrite_tac o single + >> ‘exp (ln (cos x)⁻¹) = (cos x)⁻¹’ by + ( gs[EXP_LN] + >> irule COS_POS_PI + >> gs[] >> irule REAL_LT_TRANS >> qexists_tac ‘0’ + >> gs[PI_POS] + ) + >> gs[] + ) + >> pop_assum $ rewrite_tac o single + >>‘(cos (acs (1 - t))) = 1-t’ by + ( irule ACS_COS + >> conj_tac + >- ( ‘0 <= t ==> 1 - t <= 1’ by REAL_ARITH_TAC + >> first_assum irule + >> UNDISCH_TAC “(0:real) < t” + >> REAL_ARITH_TAC + ) + >> ‘t <= 2 ==> -1 <= 1 - t’ by REAL_ARITH_TAC + >> first_assum irule + >> irule REAL_LE_TRANS + >> qexists_tac ‘1 - cos x’ + >> conj_tac + >- gs[] + >> irule REAL_LT_IMP_LE + >>‘- 1 < cos x ==> 1 - cos x < 2’ by REAL_ARITH_TAC + >> first_assum irule + >> irule REAL_LT_TRANS + >> qexists_tac ‘0:real’ + >> conj_tac + >- gs[] + >> gs[COS_POS_PI2] + ) + >> pop_assum $ rewrite_tac o single + >> ‘(1 - t)⁻¹ = exp (-ln (1 - t))’ by + (‘ ln (inv (1-t)) = - ln(1-t)’ by + ( irule LN_INV + >> ‘0+t < 1 ==> 0 < 1 - t’ by gs[REAL_LT_ADD_SUB] + >> first_assum irule + >> ‘0 + t = t ’ by REAL_ARITH_TAC + >> pop_assum $ rewrite_tac o single + >> irule REAL_LET_TRANS + >> qexists_tac ‘1 - cos x’ + >> conj_tac + >- gs[] + >> gs[] + ) + >> ‘-ln (1 - t) = ln (1 - t)⁻¹ ’ by gs[] + >> pop_assum $ rewrite_tac o single + >> ‘ exp (ln (1 - t)⁻¹) = (1 - t)⁻¹’ by + ( rewrite_tac[EXP_LN] + >> ‘0 < 1 - t ’ by + ( ‘0 + t < 1 ==> 0 < 1 - t ’ by REAL_ARITH_TAC + >> first_assum irule + >> ‘0 + t = t’ by REAL_ARITH_TAC + >> pop_assum $ rewrite_tac o single + >> irule REAL_LET_TRANS + >> qexists_tac ‘1 - cos x’ + >> conj_tac + >- gs[] + >> gs[] + ) + >> gs[] + ) + >> gs[] + ) + >> pop_assum $ rewrite_tac o single + >> gs[GSYM EXP_N] +QED + +(** McLaurin Series for atan x **) +Theorem REAL_ATN_POWSER_SUMMABLE: + ∀ x. abs(x) < &1 ⇒ + summable (λ n. + (if EVEN n then &0 + else -(&1) pow ((n - 1) DIV 2) / &n) * x pow n) +Proof + REPEAT STRIP_TAC THEN MATCH_MP_TAC seqTheory.SER_COMPAR THEN + EXISTS_TAC “\n. abs(x) pow n” THEN CONJ_TAC + >- ( EXISTS_TAC “0:num” THEN REPEAT STRIP_TAC THEN REWRITE_TAC[] THEN + gs[] >> COND_CASES_TAC + >- gs[REAL_ABS_POS] + >> ‘ODD (n)’ by gs[ODD_EVEN] + >> ‘∃p. (n) = SUC (2 * p)’ by gs[ODD_EXISTS] + >> pop_assum $ rewrite_tac o single + >> gs[GSYM DIV2_def, ABS_MUL, ABS_DIV, GSYM POW_ABS] + >> ‘(abs x pow SUC (2 * p)) = 1 * (abs x pow SUC (2 * p))’ by gs[] + >> pop_assum $ once_rewrite_tac o single + >> ‘ &SUC (2 * p) * (1 * abs x pow SUC (2 * p)) = + &SUC (2 * p) * abs x pow SUC (2 * p)’ by gs[] + >> pop_assum $ rewrite_tac o single + >> irule REAL_LE_MUL2 + >> rpt conj_tac >> gs[] + ) + >> REWRITE_TAC[seqTheory.summable] + >> EXISTS_TAC “inv(&1 - abs x)” + >> MATCH_MP_TAC seqTheory.GP + >> ASM_REWRITE_TAC[ABS_ABS] +QED + +Theorem REAL_ATN_POWSER_SUMMABLE : + ∀ x. + abs(x) < &1 ⇒ + summable (λ n. (if EVEN n then &0 + else -(&1) pow ((n - 1) DIV 2) / &n) * x pow n) +Proof + REPEAT STRIP_TAC THEN MATCH_MP_TAC seqTheory.SER_COMPAR THEN + EXISTS_TAC “\n. abs(x) pow n” THEN CONJ_TAC + >- ( EXISTS_TAC “0:num” THEN REPEAT STRIP_TAC THEN REWRITE_TAC[] THEN gs[] + >> COND_CASES_TAC + >- gs[] + >> gs[] >> gs[REAL_ABS_MUL] + >> ‘abs x pow n = &1 * abs x pow n’ by gs[] + >> pop_assum $ once_rewrite_tac o single + >> irule REAL_LE_MUL2 + >> rpt conj_tac + >- ( ‘ abs (&n)⁻¹ = ( abs &n)⁻¹’ by gs[ABS_INV] + >> pop_assum $ rewrite_tac o single + >> irule REAL_INV_LE_1 >> gs[] + >> ‘ODD n’ by gs[EVEN_ODD] + >> ‘∃m. n = SUC (2 * m)’ by gs[ODD_EXISTS] + >> pop_assum $ rewrite_tac o single + >> gs[] + ) + >- gs[POW_ABS] + >- gs[] + >> gs[] + ) + >> REWRITE_TAC[seqTheory.summable] >> EXISTS_TAC “inv(&1 - abs x)” + >> MATCH_MP_TAC seqTheory.GP >> gs[] +QED + +Theorem REAL_ATN_POWSER_DIFFS_SUMMABLE: + ∀ x. + abs(x) < &1 ⇒ + summable (λ n. diffs (λ n. (if EVEN n then &0 + else -(&1) pow ((n - 1) DIV 2) / &n)) n * + x pow n) +Proof + REPEAT STRIP_TAC THEN REWRITE_TAC[powserTheory.diffs] THEN + MATCH_MP_TAC seqTheory.SER_COMPAR THEN + EXISTS_TAC “\n. abs(x) pow n” THEN CONJ_TAC + >- ( EXISTS_TAC “0:num” THEN REPEAT STRIP_TAC THEN REWRITE_TAC[] THEN gs[] + >> COND_CASES_TAC + >- gs[] + >> gs[] >> gs[REAL_ABS_MUL, GSYM POW_ABS] + ) + >> REWRITE_TAC[seqTheory.summable] THEN EXISTS_TAC “inv(&1 - abs x)” THEN + MATCH_MP_TAC seqTheory.GP THEN gs[] +QED + +Theorem REAL_ATN_POWSER_DIFFS_SUM: + ∀ x. + abs(x) < &1 ⇒ + (λ n. diffs + (λ n. (if EVEN n then &0 else -(&1) pow ((n - 1) DIV 2) / &n)) n * x pow n) + sums (inv(&1 + x pow 2)) +Proof + rpt strip_tac + >> first_assum $ mp_then Any mp_tac REAL_ATN_POWSER_DIFFS_SUMMABLE + >> disch_then $ (fn th => + mp_then Any mp_tac seqTheory.SUMMABLE_SUM th + >> mp_then Any mp_tac seqTheory.SER_PAIR th) + >> ‘(λ n. sum (2 * n,2) + (λ n. diffs + (λ n. (if EVEN n then &0 + else -(&1) pow ((n - 1) DIV 2) / &n)) n * x pow n)) = + (λ n. -(x pow 2) pow n)’ + by ( + ABS_TAC + >> gs[CONV_RULE numLib.SUC_TO_NUMERAL_DEFN_CONV sum, powserTheory.diffs, ADD_CLAUSES, EVEN_MULT, EVEN] + >> ‘~ EVEN (2 * n + 1)’ + by (gs[GSYM ODD_EVEN, ODD_EXISTS] >> qexists_tac ‘n’ >> gs[]) + >> gs[GSYM REAL_POW_POW] + >> ‘((2 * n) DIV 2) = n’ + by (‘2 * n = n * 2’ by gs[] >> pop_assum $ rewrite_tac o single >> irule MULT_DIV >> gs[]) + >> pop_assum $ rewrite_tac o single + >> gs[GSYM POW_MUL]) + >> pop_assum $ rewrite_tac o single + >> ‘(λ n. - (x pow 2) pow n) sums inv (&1 + x pow 2)’ + by ( + once_rewrite_tac [REAL_ARITH “&1 + x:real = &1 - (- x)”] + >> irule seqTheory.GP + >> rewrite_tac[ABS_NEG, ABS_MUL, POW_2] + >> ‘1:real = 1 * 1’ by real_tac + >> pop_assum $ once_rewrite_tac o single + >> irule REAL_LT_MUL2 + >> gs[ABS_POS]) + >> pop_assum mp_tac + >> mesonLib.MESON_TAC [seqTheory.SUM_UNIQ] +QED + +Theorem REAL_ATN_POWSER_DIFFS_DIFFS_SUMMABLE: + ∀ x. + abs(x) < &1 ⇒ + summable (λ n. diffs (diffs + (λ n. (if EVEN n then &0 + else -(&1) pow ((n - 1) DIV 2) / &n))) n * x pow n) +Proof + REPEAT STRIP_TAC THEN REWRITE_TAC[powserTheory.diffs] THEN + MATCH_MP_TAC seqTheory.SER_COMPAR THEN + EXISTS_TAC “\n. &(SUC n) * abs(x) pow n” THEN CONJ_TAC + >- ( EXISTS_TAC “0:num” THEN REPEAT STRIP_TAC THEN gs[] + >> REWRITE_TAC[ABS_N, REAL_ABS_MUL, GSYM REAL_MUL_ASSOC] THEN + ‘&SUC n * abs x pow n = abs x pow n * &SUC n ’ by gs[] + >> pop_assum $ rewrite_tac o single + >> gs[POW_ABS] + >> ‘ abs (x pow n) * + abs + (if EVEN (SUC (SUC n)) then 0 + else -1 pow (SUC n DIV 2) / &SUC (SUC n)) * &(SUC n * SUC (SUC n)) = + abs (x pow n) * + ( abs + (if EVEN (SUC (SUC n)) then 0 + else -1 pow (SUC n DIV 2) / &SUC (SUC n)) * &(SUC n * SUC (SUC n)))’ by + gs[] + >> pop_assum $ rewrite_tac o single + >> irule REAL_LE_LMUL1 + >> conj_tac + >- ( gs[] + >> COND_CASES_TAC + >- gs[] + >> gs[ABS_DIV] >> gs[] + ) + >> gs[] + ) + >> MATCH_MP_TAC seqTheory.SER_RATIO THEN + SUBGOAL_THEN “?c. abs(x) < c /\ c < &1” STRIP_ASSUME_TAC + >- ( EXISTS_TAC “(&1 + abs(x)) / &2” + >> gs[] >> UNDISCH_TAC “abs(x) < &1” >> REAL_ARITH_TAC + ) + >> EXISTS_TAC “c:real” THEN ASM_REWRITE_TAC[] + >> ‘?N. !n. n >= N ==> &(SUC(SUC n)) * abs(x) <= &(SUC n) * c’ by + ( ASM_CASES_TAC “x : real= &0” + >- ( ASM_REWRITE_TAC[ABS_N, REAL_MUL_RZERO] THEN + EXISTS_TAC “0:num” THEN REPEAT STRIP_TAC THEN + MATCH_MP_TAC REAL_LE_MUL THEN + REWRITE_TAC[REAL_POS] THEN + UNDISCH_TAC “abs(x) < c” THEN REAL_ARITH_TAC + ) + >> ‘?N. &1 <= &N * (c / abs x - &1)’ by + ( assume_tac SIMP_REAL_ARCH + >> pop_assum $ qspec_then ‘&1 / (c / abs x − 1)’ assume_tac + >> pop_assum mp_tac + >> rpt strip_tac + >> qexists_tac ‘n:num’ + >> assume_tac REAL_LE_LDIV_EQ + >> pop_assum $ qspecl_then [‘&1’, ‘&n’, ‘(c / abs x − 1)’] assume_tac + >> ‘0 < c / abs x − 1’ by + ( ‘ 0 < abs x’ by gs[GSYM ABS_NZ] + >> ‘&1 < c / abs x ⇒ 0 < c / abs x − 1 ’ by REAL_ARITH_TAC + >> first_assum irule + >> assume_tac REAL_LT_RDIV_EQ + >> pop_assum $ qspecl_then [‘&1’, ‘c’, ‘abs x’] assume_tac + >> res_tac + >> first_assum irule + >> gs[] + ) + >> res_tac + ) + >> qexists_tac ‘N:num’ >> rpt strip_tac + >> gs[GSYM REAL_OF_NUM_SUC] + >> once_rewrite_tac[GSYM REAL_OF_NUM_ADD] + >> gs[REAL_ADD_LDISTRIB] + >> irule REAL_LE_ADD2 + >> conj_tac + >- ( gs[GSYM REAL_OF_NUM_SUC] + >> once_rewrite_tac[GSYM REAL_OF_NUM_ADD] + >> ‘ abs x * (&n + 1) = (&n + 1) * abs x ’ by gs[] + >> pop_assum $ rewrite_tac o single + >> assume_tac REAL_LE_RDIV_EQ + >> pop_assum $ qspecl_then [‘(&n + 1)’, ‘c * &n’, ‘abs x’] assume_tac + >> ‘ 0 < abs x’ by gs[GSYM ABS_NZ] + >> res_tac + >> pop_assum kall_tac + >> first_assum irule + >> ‘c * &n / abs x = &n * (c / abs x)’ by gs[] + >> pop_assum $ rewrite_tac o single + >> ‘1 ≤ &n * ((c / abs x) - &1) ⇒ &n + 1 ≤ &n * (c / abs x)’ by + REAL_ARITH_TAC + >> first_assum irule + >> irule REAL_LE_TRANS + >> qexists_tac ‘&N * (c / abs x − 1)’ + >> conj_tac + >- gs[] + >> ‘&N * (c / abs x − 1) = (c / abs x − 1) * &N ’ by gs[] + >> pop_assum $ rewrite_tac o single + >> ‘&n * (c / abs x − 1) = (c / abs x − 1) * &n’ by gs[] + >> pop_assum $ rewrite_tac o single + >> irule REAL_LE_LMUL_IMP + >> conj_tac + >- gs[REAL_LE] + >> ‘&1 ≤ c / abs x ⇒ 0 ≤ c / abs x − 1 ’ by REAL_ARITH_TAC + >> first_assum irule + >> irule REAL_LE_RDIV + >> gs[REAL_LT_IMP_LE] + ) + >> gs[REAL_LT_IMP_LE] + ) + >> qexists_tac ‘N:num’ + >> rpt strip_tac + >> gs[pow, REAL_ABS_MUL] + >> ‘abs x * abs (abs x pow n) * &SUC (SUC n) = + (abs x * &SUC (SUC n)) * abs x pow n’ by gs[] + >> pop_assum $ rewrite_tac o single + >> ‘ c * abs (abs x pow n) * &SUC n = + (c * &SUC n) * (abs x pow n) ’ by gs[] + >> pop_assum $ rewrite_tac o single + >> irule REAL_LE_MUL2 + >> rpt conj_tac + >- gs[] + >- gs[] + >- ( irule REAL_LE_MUL >> gs[] ) + >> gs[] +QED + +Theorem REAL_ATN_POWSER_DIFFL: + ∀ x. + abs(x) < &1 ⇒ + ((λ x. suminf (λ n. (if EVEN n then &0 + else -(&1) pow ((n - 1) DIV 2) / &n) * x pow n)) + diffl (inv(&1 + x pow 2))) x +Proof + REPEAT STRIP_TAC THEN + FIRST_ASSUM(MP_TAC o MATCH_MP REAL_ATN_POWSER_DIFFS_SUM) THEN + DISCH_THEN(SUBST1_TAC o MATCH_MP seqTheory.SUM_UNIQ) THEN + ‘(λx. suminf + (λn. + (if EVEN n then 0 else -1 pow ((n − 1) DIV 2) / &n) * + x pow n)) = + (λx. suminf + (λn. + ( (\m. (if EVEN n then 0 else -1 pow ((n − 1) DIV 2) / &n)) n) * + x pow n)) ’ by gs[] + >> pop_assum $ once_rewrite_tac o single + >> assume_tac powserTheory.TERMDIFF + >> SUBGOAL_THEN “?K. abs(x) < abs(K) /\ abs(K) < &1” STRIP_ASSUME_TAC + >- ( EXISTS_TAC “(&1 + abs(x)) / &2” THEN + gs[REAL_LT_LDIV_EQ, ABS_DIV, ABS_N, + REAL_LT_RDIV_EQ, REAL_LT] + >> UNDISCH_TAC “abs(x) < &1” THEN REAL_ARITH_TAC + ) + >> qpat_x_assum ‘∀c k' x. _’ $ qspecl_then [‘(λn. if EVEN n then 0 else -1 pow ((n − 1) DIV 2) / &n)’, + ‘K'’, ‘x’] assume_tac + >> ‘summable + (λn. + (λn. if EVEN n then 0 else -1 pow ((n − 1) DIV 2) / &n) n * + K' pow n) ∧ + summable + (λn. + diffs (λn. if EVEN n then 0 else -1 pow ((n − 1) DIV 2) / &n) + n * K' pow n) ∧ + summable + (λn. + diffs + (diffs + (λn. if EVEN n then 0 else -1 pow ((n − 1) DIV 2) / &n)) + n * K' pow n) ∧ abs x < abs K'’ by + ( rpt conj_tac + >- ( ‘summable + (λn. + (λn. if EVEN n then 0 else -1 pow ((n − 1) DIV 2) / &n) n * + K' pow n) = + summable + (λn. (if EVEN n then 0 else -1 pow ((n − 1) DIV 2) / &n) * + K' pow n)’ by gs[] + >> pop_assum $ rewrite_tac o single + >> gs[ REAL_ATN_POWSER_SUMMABLE] + ) + >- gs[REAL_ATN_POWSER_DIFFS_SUMMABLE] + >- gs[REAL_ATN_POWSER_DIFFS_DIFFS_SUMMABLE] + >> gs[] + ) + >> res_tac + >> gs[] +QED + +Theorem REAL_ATN_POWSER: + ∀ x. + abs(x) < &1 ⇒ + (λ n. (if EVEN n then &0 + else -(&1) pow ((n - 1) DIV 2) / &n) * x pow n) + sums (atn x) +Proof + REPEAT STRIP_TAC THEN + FIRST_ASSUM(MP_TAC o MATCH_MP REAL_ATN_POWSER_SUMMABLE) THEN + DISCH_THEN(MP_TAC o MATCH_MP seqTheory.SUMMABLE_SUM) THEN + SUBGOAL_THEN + “suminf (\n. (if EVEN n then &0 + else -(&1) pow ((n - 1) DIV 2) / &n) * x pow n) = atn(x)” + (fn th => REWRITE_TAC[th]) THEN + ONCE_REWRITE_TAC[REAL_ARITH “(a = b) <=> ((a:real) - (b:real) = &0)”] THEN + SUBGOAL_THEN + “suminf (\n. (if EVEN n then &0 + else -(&1) pow ((n - 1) DIV 2) / &n) * &0 pow n) - + atn(&0) = &0” + MP_TAC + >- ( MATCH_MP_TAC(REAL_ARITH “(a = &0) /\ (b = &0) ==> ((a:real) - (b:real) = &0)”) + >> CONJ_TAC + >- ( CONV_TAC SYM_CONV THEN MATCH_MP_TAC seqTheory.SUM_UNIQ THEN + MP_TAC(SPEC “&0:real” seqTheory.GP) THEN + gs[ABS_N, REAL_LT] THEN + DISCH_THEN(MP_TAC o SPEC “&0:real” o MATCH_MP seqTheory.SER_CMUL) THEN + REWRITE_TAC[REAL_MUL_LZERO] THEN + MATCH_MP_TAC(tautLib.TAUT `(a = b) ==> a ==> b`) THEN + AP_THM_TAC THEN AP_TERM_TAC THEN ABS_TAC THEN + COND_CASES_TAC THEN ASM_REWRITE_TAC[REAL_MUL_LZERO] THEN + CONV_TAC SYM_CONV THEN gs[] THEN + ‘ODD (n)’ by gs[ODD_EVEN] + >> ‘∃p. (n) = SUC (2 * p)’ by gs[ODD_EXISTS] + >> pop_assum $ rewrite_tac o single + >> gs[POW_0] + ) + >> gs[ATN_0] + ) + >> ASM_CASES_TAC “x = &0 : real” THEN ASM_REWRITE_TAC[] THEN + strip_tac + >> ‘&0 = suminf + (λn. (if EVEN n then 0 else -1 pow ((n − 1) DIV 2) / &n) * 0 pow n) − + atn 0’ by gs[] + >> pop_assum $ once_rewrite_tac o single + >> MP_TAC(SPEC “\x. suminf (\n. (if EVEN n then &0 + else -(&1) pow ((n - 1) DIV 2) / &n) * x pow n) - + atn x” DIFF_ISCONST_END_SIMPLE) THEN + FIRST_ASSUM(DISJ_CASES_TAC o MATCH_MP (REAL_ARITH + “~(x = &0) ==> &0 < (x:real) \/ (x:real) < &0”)) + >- ( rpt strip_tac + >> pop_assum $ qspecl_then [‘&0:real’, ‘x: real’] assume_tac + >> res_tac >> gs[] + >> first_assum irule + >> rpt strip_tac >> gs[] + >> ‘&0 = (inv(&1 + x' pow 2)) - (inv(&1 + x' pow 2))’ by gs[] + >> ‘ ((λx''. + suminf + (λn. + x'' pow n * + if EVEN n then 0 else -1 pow ((n − 1) DIV 2) / &n) − + atn x'') diffl 0) x' = + ((λx''. + ((\x. suminf + (λn. + x pow n * + if EVEN n then 0 else -1 pow ((n − 1) DIV 2) / &n)) x'') − + ( (\x. atn x) x'')) diffl ( (inv(&1 + x' pow 2)) - (inv(&1 + x' pow 2)))) x'’ + by (pop_assum $ once_rewrite_tac o single >> gs[]) + >> pop_assum $ rewrite_tac o single + >> irule limTheory.DIFF_SUB + >> conj_tac + >- ( ‘(λx. + suminf + (λn. + x pow n * + if EVEN n then 0 else -1 pow ((n − 1) DIV 2) / &n)) = + (\x. suminf (\n. (if EVEN n then &0 + else -(&1) pow ((n - 1) DIV 2) / &n) * x pow n)) ’ + by (pop_assum $ once_rewrite_tac o single >> gs[]) + >> pop_assum $ rewrite_tac o single + >> irule REAL_ATN_POWSER_DIFFL + >> pop_assum $ kall_tac + >> gs[ABS_BOUNDS_LT] + >> conj_tac + >- (irule REAL_LTE_TRANS >> qexists_tac ‘&0’ >> gs[]) + >> irule REAL_LET_TRANS >> qexists_tac ‘x’ >> gs[]) + >> pop_assum $ kall_tac + >> ‘(λx. atn x) = atn’ by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> gs[DIFF_ATN] + ) + >> rpt strip_tac + >> pop_assum $ qspecl_then [‘x: real’, ‘&0:real’ ] assume_tac + >> res_tac >> gs[] + >> first_assum irule + >> rpt strip_tac + >> ‘&0 = (inv(&1 + x' pow 2)) - (inv(&1 + x' pow 2))’ by gs[] + >> ‘ ((λx''. + suminf + (λn. + x'' pow n * + if EVEN n then 0 else -1 pow ((n − 1) DIV 2) / &n) − + atn x'') diffl 0) x' = + ((λx''. + ((\x. suminf + (λn. + x pow n * + if EVEN n then 0 else -1 pow ((n − 1) DIV 2) / &n)) x'') − + ( (\x. atn x) x'')) diffl ( (inv(&1 + x' pow 2)) - (inv(&1 + x' pow 2)))) x'’ + by (pop_assum $ rewrite_tac o single >> gs[]) + >> pop_assum $ rewrite_tac o single + >> pop_assum kall_tac + >> irule limTheory.DIFF_SUB + >> conj_tac + >- (‘(λx. + suminf + (λn. + x pow n * + if EVEN n then 0 else -1 pow ((n − 1) DIV 2) / &n)) = + (\x. suminf (\n. (if EVEN n then &0 + else -(&1) pow ((n - 1) DIV 2) / &n) * x pow n)) ’ + by gs[] + >> pop_assum $ rewrite_tac o single + >> irule REAL_ATN_POWSER_DIFFL + >> gs[ABS_BOUNDS_LT] + >> conj_tac + >- ( irule REAL_LTE_TRANS >> qexists_tac ‘x’ >> gs[] ) + >> irule REAL_LET_TRANS >> qexists_tac ‘&0’ >> gs[] + ) + >> ‘(λx. atn x) = atn’ by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> gs[DIFF_ATN] +QED + +Theorem MCLAURIN_ATN: + ∀ x n. + abs(x) < &1 ⇒ + abs(atn x - + sum(0,n) (\m. (if EVEN m then &0 + else -(&1) pow ((m - 1) DIV 2) / &m) * + x pow m)) ≤ + abs(x) pow n / (&1 - abs x) +Proof + REPEAT STRIP_TAC + >> FIRST_ASSUM(MP_TAC o MATCH_MP REAL_ATN_POWSER) THEN + DISCH_THEN(fn th => ASSUME_TAC(SYM(MATCH_MP seqTheory.SUM_UNIQ th)) THEN + MP_TAC(MATCH_MP seqTheory.SUM_SUMMABLE th)) THEN + DISCH_THEN(MP_TAC o MATCH_MP seqTheory.SER_OFFSET) THEN + DISCH_THEN(MP_TAC o SPEC “n:num”) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o MATCH_MP seqTheory.SUM_UNIQ) THEN + MATCH_MP_TAC(REAL_ARITH + “abs(r) <= e ==> (f - s = r) ==> abs(f - s) <= e”) THEN + SUBGOAL_THEN + “(\m. abs(x) pow (m + n)) sums ((abs(x) pow n) * inv(&1 - abs(x)))” + ASSUME_TAC + >- ( FIRST_ASSUM(MP_TAC o MATCH_MP seqTheory.GP o MATCH_MP (REAL_ARITH + “abs(x) < &1 ==> abs(abs x) < &1”)) THEN + DISCH_THEN(MP_TAC o SPEC “abs(x) pow n” o MATCH_MP seqTheory.SER_CMUL) + THEN ONCE_REWRITE_TAC[ADD_SYM] THEN REWRITE_TAC[GSYM REAL_POW_ADD] + >> gs[] >> strip_tac >> REWRITE_TAC[REAL_POW_ADD] >> gs[] + >> ‘(λm. abs x pow m * abs x pow n) = (λn'. abs x pow n * abs x pow n')’ + by gs[FUN_EQ_THM] + >> pop_assum $ rewrite_tac o single + >> gs[] + ) + >> FIRST_ASSUM(SUBST1_TAC o MATCH_MP seqTheory.SUM_UNIQ o + REWRITE_RULE[GSYM real_div]) + THEN + SUBGOAL_THEN + “!m. abs((if EVEN (m + n) then &0 + else -(&1) pow (((m + n) - 1) DIV 2) / &(m + n)) * + x pow (m + n)) + <= abs(x) pow (m + n)” + ASSUME_TAC + >- ( GEN_TAC THEN COND_CASES_TAC THEN + gs[REAL_MUL_LZERO, ABS_N, POW_POS, REAL_ABS_POS] THEN + REWRITE_TAC[REAL_ABS_MUL, ABS_DIV, GSYM POW_ABS, ABS_NEG] THEN + REWRITE_TAC[ABS_N, POW_ONE, REAL_MUL_LID] THEN + rewrite_tac[REAL_MUL_RID] + >> ‘abs x pow (m + n) = &1 * abs x pow (m + n) ’ by + gs[REAL_MUL_LID] + >> pop_assum $ once_rewrite_tac o single + >> ‘abs (&(m + n))⁻¹ * (1 * abs x pow (m + n)) = + abs (&(m + n))⁻¹ * abs x pow (m + n)’ by gs[] + >> pop_assum $ rewrite_tac o single + >> irule REAL_LE_MUL2 + >> rpt conj_tac + >- ( ‘ abs (&(m + n))⁻¹ = (abs (&(m + n)))⁻¹’ by + ( irule ABS_INV + >> ‘ODD (m+n)’ by gs[ODD_EVEN] + >> ‘?p. (m+n) = SUC (2 * p)’ by gs[ODD_EXISTS] + >> pop_assum $ rewrite_tac o single + >> gs[] + ) + >> pop_assum $ rewrite_tac o single + >> irule REAL_INV_LE_1 + >> rewrite_tac[ABS_N] + >> ‘ODD (m+n)’ by gs[ODD_EVEN] + >> ‘?p. (m+n) = SUC (2 * p)’ by gs[ODD_EXISTS] + >> pop_assum $ rewrite_tac o single + >> gs[] + ) + >- gs[] + >- gs[ABS_POS] + >> gs[ABS_POS] + ) + >> MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC + “suminf (\m. abs((if EVEN (m + n) then &0 + else -(&1) pow (((m + n) - 1) DIV 2) / &(m + n)) * + x pow (m + n)))” THEN + CONJ_TAC + >- ( gs[] + >> ‘ suminf + (λm. + abs + (x pow (m + n) * + if EVEN (m + n) then 0 + else -1 pow ((m + n - 1) DIV 2) / &(m + n))) = + suminf + (λm. + abs + ( ( \n'. (x pow (n + n') * + if EVEN (n + n') then 0 + else -1 pow ((n + n' - 1) DIV 2) / &(n + n'))) m))’ by + gs[] + >> pop_assum $ rewrite_tac o single + >> irule seqTheory.SER_ABS THEN MATCH_MP_TAC seqTheory.SER_COMPARA THEN + EXISTS_TAC “\m. abs(x) pow (m + n)” THEN + ASM_REWRITE_TAC[] THEN conj_tac + >- ( qexists_tac ‘0’ >> rpt strip_tac + >> gs[] >> pop_assum $ qspec_then ‘n'’ assume_tac + >> gs[] + ) + >> mesonLib.ASM_MESON_TAC[seqTheory.SUM_SUMMABLE] + ) + >> MATCH_MP_TAC seqTheory.SER_LE THEN ASM_REWRITE_TAC[] THEN CONJ_TAC + >- ( strip_tac >> gs[] >> pop_assum $ qspec_then ‘n'’ assume_tac >> gs[] ) + >> conj_tac + >- ( ‘ (λm. + abs + ((if EVEN (m + n) then 0 + else -1 pow ((m + n - 1) DIV 2) / &(m + n)) * + x pow (m + n))) = + (λm. + abs + ((\n'. ((if EVEN (n' + n) then 0 + else -1 pow ((n' + n - 1) DIV 2) / &(n' + n)) * + x pow (n' + n))) m))’ by gs[] + >> pop_assum $ rewrite_tac o single + >> MATCH_MP_TAC seqTheory.SER_COMPARA THEN + EXISTS_TAC “\m. abs (x) pow (m + n)” THEN + ASM_REWRITE_TAC[] >> conj_tac + >- ( qexists_tac ‘0’ >> rpt strip_tac + >> gs[] >> pop_assum $ qspec_then ‘n'’ assume_tac + >> gs[] + ) + >> mesonLib.ASM_MESON_TAC[seqTheory.SUM_SUMMABLE] + ) + >> mesonLib.ASM_MESON_TAC[seqTheory.SUM_SUMMABLE] +QED + +Theorem MCLAURIN_EXP_COMPOSITE: + ! x y err. + 0 <= err /\ + abs (x - y) <= err ==> + abs (exp x - exp y) <= exp x * (exp err - 1) +Proof + rpt strip_tac + >> mp_with_then strip_assume_tac ‘abs (x - y) <= err’ ERR_ABS_SIMP + >> gs[abs] + >> Cases_on ‘0 <= x - y’ >> gs[REAL_NOT_LE] + >- ( + ‘y <= x’ by real_tac + >> ‘exp y <= exp x /\ exp x <= exp (x + err) /\ exp (x - err) <= exp y ’ + by gs[EXP_MONO_LE] + >> ‘0 <= exp x - exp y’ by real_tac + >> gs[] + >> transitivity_for ‘exp (y + err) - exp y’ >> conj_tac + >> rewrite_tac [real_sub] + >- gs[REAL_LE_RADD, EXP_MONO_LE] + >> rewrite_tac[EXP_ADD] + >> ‘exp y * exp err = exp y * (1 + (exp err - 1))’ by real_tac + >> pop_assum $ once_rewrite_tac o single + >> real_rw ‘exp y * (1 + (exp err - 1)) + - exp y = exp y * (exp err - 1)’ + >> rewrite_tac[real_sub] + >> irule REAL_LE_RMUL_IMP + >> gs[EXP_MONO_LE, GSYM real_sub, EXP_MINUS_ONE_POS]) + >> ‘x < y’ by real_tac + >> ‘exp x < exp y’ by gs[EXP_MONO_LT] + >> ‘~ (0 <= exp x - exp y)’ by (gs[REAL_NOT_LE] >> real_tac) + >> gs[] + >> ‘x <= y’ by real_tac + >> ‘exp x <= exp y /\ exp y <= exp (x + err) /\ exp (x - err) <= exp y’ + by gs[EXP_MONO_LE] + >> rewrite_tac [REAL_NEG_ADD, real_sub, REAL_NEG_NEG] + >> ‘- exp x + exp y = exp y - exp x’ by real_tac + >> pop_assum $ rewrite_tac o single + >> transitivity_for ‘exp (x + err) - exp x’ + >> conj_tac >- gs[real_sub, REAL_LE_RADD] + >> rewrite_tac[EXP_ADD, real_sub] + >> real_rw ‘exp x * exp err + -exp x = exp x * (1 + (exp err - 1)) + - exp x’ + >> real_rw ‘exp x * (1 + (exp err - 1)) + - exp x = exp x * (exp err + - 1)’ + >> gs[] +QED + +Theorem cos_sub_1_neg: + ∀ x. cos x - 1 ≤ 0 +Proof + rpt strip_tac + >> transitivity_for ‘1 - 1’ + >> reverse conj_tac >- real_tac + >> rewrite_tac[real_sub] + >> gs[REAL_LE_LADD, COS_BOUNDS] +QED + +Definition abs_alt_def: + abs_alt (x:real) = if x ≤ 0 then - x else x +End + +Theorem abs_alt_abs: + abs_alt x = abs x +Proof + gs[abs_alt_def, abs] >> cond_cases_tac + >- ( + Cases_on ‘x = 0’ >> gs[] + >> ‘~ (0 ≤ x)’ by real_tac + >> gs[]) + >> gs[REAL_NOT_LE, REAL_LE_LT] +QED + +Theorem cos_decreasing_abs: + 0 ≤ x ∧ x ≤ pi / 2 ∧ + abs y ≤ x ⇒ + cos x ≤ cos y +Proof + rpt strip_tac >> gs[abs] + >> ‘x ≤ pi’ by (transitivity_for ‘pi/2’ >> conj_tac >- gs[] + >> rewrite_tac [REAL_LE_LT] >> gs[PI2_lt_PI]) + >> Cases_on ‘0 ≤ y’ >> gs[] + >- ( + irule cos_decr_0_pi >> gs[] + >> real_tac) + >> ‘cos y = cos (- y)’ by gs[COS_NEG] + >> pop_assum $ rewrite_tac o single + >> irule cos_decr_0_pi >> gs[REAL_NOT_LE] + >> conj_tac >> real_tac +QED + +Theorem sin_increasing_abs: + 0 ≤ x ∧ x ≤ pi / 2 ∧ + abs y ≤ x ⇒ + abs (sin y) ≤ abs(sin x) +Proof + rpt strip_tac >> gs[abs] + >> ‘0 ≤ sin x’ by (irule SIN_POS_PI2_LE >> gs[]) + >> gs[] >> Cases_on ‘0 ≤ y’ >> gs[] + >- ( + ‘y ≤ pi / 2’ by (transitivity_for ‘x’ >> gs[]) + >> ‘0 ≤ sin y’ by (irule SIN_POS_PI2_LE >> gs[]) + >> gs[] + >> irule sin_incr_0_pi2 >> gs[]) + >> gs[REAL_NOT_LE] + >> ‘y ≤ 0’ by real_tac + >> ‘- (pi/2) ≤ y’ by (irule REAL_NEG_LE1 >> transitivity_for ‘x’ >> gs[]) + >> ‘sin y ≤ 0’ + by (drule sin_negpi2_0_le >> disch_then drule >> gs[]) + >> gs[GSYM abs, GSYM abs_alt_abs, abs_alt_def, GSYM SIN_NEG] + >> ‘-y ≤ pi/2’ by (transitivity_for ‘x’ >> gs[]) + >> irule sin_incr_0_pi2 >> gs[] +QED + +Theorem MCLAURIN_SIN_COMPOSITE: + ∀ x y err. + 0 ≤ err ∧ err ≤ pi / 2 ∧ + abs (x - y) ≤ err ⇒ + abs (sin x - sin y) ≤ abs (cos err - 1) + sin err +Proof + rpt strip_tac >> imp_res_tac abs_exists + >> VAR_EQ_TAC + >> rewrite_tac[SIN_ADD] + >> ‘cos d = 1 + (cos d - 1)’ by real_tac + >> pop_assum $ once_rewrite_tac o single + >> rewrite_tac[REAL_LDISTRIB, REAL_MUL_RID] + >> rewrite_tac[real_sub, REAL_NEG_ADD, REAL_ADD_ASSOC] + >> ‘sin x + - sin x = 0’ by real_tac + >> pop_assum $ rewrite_tac o single + >> rewrite_tac[REAL_ADD_LID] + >> qmatch_goalsub_abbrev_tac ‘abs (sin_cos_1 + cos_sin)’ + >> transitivity_for ‘abs sin_cos_1 + abs cos_sin’ + >> conj_tac >- gs[REAL_ABS_TRIANGLE] + >> unabbrev_all_tac + >> irule REAL_LE_ADD2 >> rewrite_tac[ABS_NEG, ABS_MUL] + >> conj_tac + >- ( + transitivity_for ‘1 * abs (cos d + -1)’ >> conj_tac + >- ( + irule REAL_LE_RMUL_IMP >> gs[ABS_POS] + >> qspec_then ‘x’ assume_tac SIN_BOUNDS + >> qspec_then ‘- x’ assume_tac SIN_BOUNDS + >> gs[abs, SIN_NEG] >> cond_cases_tac >> gs[]) + >> rewrite_tac[REAL_MUL_LID] + >> simp[GSYM abs_alt_abs] + >> simp[abs_alt_def, GSYM real_sub, cos_sub_1_neg] + >> gs[real_sub] + >> irule cos_decreasing_abs >> gs[]) + >> ‘sin err = 1 * sin err’ by real_tac + >> pop_assum $ once_rewrite_tac o single + >> irule REAL_LE_MUL2 + >> gs[ABS_POS] >> conj_tac + >- ( + qspec_then ‘x’ assume_tac COS_BOUNDS + >> qspec_then ‘-x’ assume_tac COS_BOUNDS + >> gs[abs] >> cond_cases_tac >> gs[COS_NEG] + >> irule REAL_NEG_LE1 >> gs[]) + >> ‘0 ≤ sin err’ by (irule SIN_POS_PI2_LE >> gs[]) + >> transitivity_for ‘abs (sin err)’ >> conj_tac + >- (irule sin_increasing_abs >> gs[]) + >> gs[abs] +QED + +Theorem MCLAURIN_COS_COMPOSITE: + ∀ x y err. + 0 ≤ err ∧ err ≤ pi / 2 ∧ + abs (x - y) ≤ err ⇒ + abs (cos x - cos y) ≤ abs (cos err - 1) + sin err +Proof + rpt strip_tac >> imp_res_tac abs_exists + >> VAR_EQ_TAC + >> rewrite_tac[COS_ADD] + >> ‘cos d = 1 + (cos d - 1)’ by real_tac + >> pop_assum $ once_rewrite_tac o single + >> rewrite_tac[REAL_LDISTRIB, REAL_MUL_RID] + >> rewrite_tac[real_sub, REAL_NEG_ADD, REAL_ADD_ASSOC] + >> ‘cos x + - cos x = 0’ by real_tac + >> pop_assum $ rewrite_tac o single + >> rewrite_tac[REAL_ADD_LID] + >> qmatch_goalsub_abbrev_tac ‘abs (cos_cos_1 + sin_sin)’ + >> transitivity_for ‘abs cos_cos_1 + abs sin_sin’ + >> conj_tac >- gs[REAL_ABS_TRIANGLE] + >> unabbrev_all_tac + >> irule REAL_LE_ADD2 >> rewrite_tac[ABS_NEG, ABS_MUL] + >> conj_tac + >- ( + transitivity_for ‘1 * abs (cos d + -1)’ >> conj_tac + >- ( + irule REAL_LE_RMUL_IMP >> gs[ABS_POS] + >> qspec_then ‘x’ assume_tac COS_BOUNDS + >> qspec_then ‘x + pi’ assume_tac COS_BOUNDS + >> gs[abs, GSYM COS_PERIODIC_PI] >> cond_cases_tac >> gs[]) + >> rewrite_tac[REAL_MUL_LID] + >> simp[GSYM abs_alt_abs] + >> simp[abs_alt_def, GSYM real_sub, cos_sub_1_neg] + >> gs[real_sub] + >> irule cos_decreasing_abs >> gs[]) + >> ‘sin err = 1 * sin err’ by real_tac + >> pop_assum $ once_rewrite_tac o single + >> irule REAL_LE_MUL2 + >> gs[ABS_POS] >> conj_tac + >- ( + qspec_then ‘x’ assume_tac SIN_BOUNDS + >> qspec_then ‘-x’ assume_tac SIN_BOUNDS + >> gs[abs, SIN_NEG] >> cond_cases_tac >> gs[]) + >> ‘0 ≤ sin err’ by (irule SIN_POS_PI2_LE >> gs[]) + >> transitivity_for ‘abs (sin err)’ >> conj_tac + >- (irule sin_increasing_abs >> gs[]) + >> gs[abs] +QED + +Theorem MCLAURIN_LN_COMPOSITE: + ∀ x y err. + 0 ≤ err ∧ 0 < x ∧ 0 < y ∧ + abs (x - y) ≤ err ⇒ + abs (ln x - ln y) ≤ abs (ln (1 + err / min x y)) +Proof + rw[REAL_NEG_SUB] + >> gs[SimpR“($<=):real->real->bool”, abs] + >> ‘0 < min x y’ + by (gs[min_def] >> cond_cases_tac >> gs[]) + >> ‘0 ≤ err / min x y’ by (gs[nonzerop_def] >> cond_cases_tac >> gs[]) + >> ‘1 ≤ 1 + err / min x y’ by gs[nonzerop_def] + >> pop_assum $ mp_then Any assume_tac LN_POS >> gs[abs] + >> Cases_on ‘0 ≤ x - y’ >> gs[] + >- ( + ‘y ≤ x’ by real_tac + >> ‘ln y ≤ ln x’ by gs[GSYM LN_MONO_LE] + >> ‘0 ≤ ln x - ln y’ by real_tac + >> ‘x ≤ y + err’ by real_tac + >> ‘0 < y + err’ by real_tac + >> ‘ln x ≤ ln (y + err)’ by gs [GSYM LN_MONO_LE] + >> gs[] + >> irule REAL_LE_TRANS + >> qexists_tac ‘ln (y + err) - ln y’ >> conj_tac + >- (rewrite_tac[real_sub] >> irule REAL_LE_ADD2 >> gs[]) + >> ‘0 ≤ err / y ’ by (gs[nonzerop_def] >> cond_cases_tac >> gs[]) + >> ‘0 < 1 + err / y’ by (irule REAL_LTE_ADD >> gs[]) + >> ‘y + err = y * (1 + err / y)’ + by (gs[REAL_LDISTRIB, REAL_MUL_RID, nonzerop_def] >> cond_cases_tac >> gs[]) + >> pop_assum $ once_rewrite_tac o single + >> gs[LN_MUL] + >> ‘ln y + ln (1 + err / y) - ln y = ln (1 + err / y)’ by real_tac + >> pop_assum $ rewrite_tac o single + >> ‘0 < 1 + err / min x y’ by (irule REAL_LTE_ADD >> gs[]) + >> qpat_x_assum ‘0 < 1 + err / y’ $ mp_then Any mp_tac LN_MONO_LE + >> disch_then drule >> strip_tac >> gs[] + >> gs[nonzerop_def] >> rpt (cond_cases_tac >> gs[]) + >> irule REAL_LE_LMUL_IMP >> gs[REAL_MIN_LE2]) + >> gs[REAL_NOT_LE] + >> ‘x < y’ by real_tac + >> ‘ln x < ln y’ + by (qpat_x_assum ‘0 < x’ $ mp_then Any mp_tac $ LN_MONO_LT + >> disch_then $ qspec_then ‘y’ mp_tac >> impl_tac >> gs[]) + >> ‘~ (0 ≤ ln x - ln y)’ by (gs[REAL_NOT_LE] >> real_tac) + >> gs[REAL_NEG_SUB] + >> ‘0 < x + err’ by real_tac + >> ‘y ≤ x + err’ by real_tac + >> ‘ln y ≤ ln (x + err)’ by gs [LN_MONO_LE] + >> irule REAL_LE_TRANS + >> qexists_tac ‘ln (x + err) - ln x’ >> conj_tac + >- (rewrite_tac[real_sub] >> irule REAL_LE_ADD2 >> gs[]) + >> ‘0 ≤ err / x ’ by (gs[nonzerop_def] >> cond_cases_tac >> gs[]) + >> ‘0 < 1 + err / x’ by (irule REAL_LTE_ADD >> gs[]) + >> ‘x + err = x * (1 + err / x)’ + by (gs[REAL_LDISTRIB, REAL_MUL_RID, nonzerop_def] >> cond_cases_tac >> gs[]) + >> pop_assum $ once_rewrite_tac o single + >> gs[LN_MUL] + >> ‘ln x + ln (1 + err / x) - ln x = ln (1 + err / x)’ by real_tac + >> pop_assum $ rewrite_tac o single + >> ‘0 < 1 + err / min x y’ by (irule REAL_LTE_ADD >> gs[]) + >> qpat_x_assum ‘0 < 1 + err / x’ $ mp_then Any mp_tac LN_MONO_LE + >> disch_then drule >> strip_tac >> gs[] + >> gs[nonzerop_def] >> rpt (cond_cases_tac >> gs[]) + >> irule REAL_LE_LMUL_IMP >> gs[REAL_MIN_LE1] +QED + +Definition atnPoly_def: + atnPoly 0 = [] /\ + atnPoly (SUC n) = + if EVEN n then (atnPoly n) ++ [0] + else ( atnPoly n) ++ [-(&1) pow ((n - 1) DIV 2) / &n] +End + +Theorem atnPoly_LENGTH[simp]: + LENGTH (atnPoly n) = n +Proof + Induct_on ‘n’ >> gs[atnPoly_def] + >> cond_cases_tac >> gs[] +QED + +Theorem atnPoly_correct: + ∀ n x. + evalPoly (atnPoly n) x = + sum(0,n) (\m. (if EVEN m then &0 + else -(&1) pow ((m - 1) DIV 2) / &m) * + x pow m) +Proof + Induct_on ‘n’ >> gs[atnPoly_def, evalPoly_def, sum] + >> Cases_on ‘EVEN n’ >> gs[sum, evalPoly_app, evalPoly_def] +QED + +local + val specThm = Q.SPEC ‘4’ (SPEC_ALL REAL_LT_RDIV_EQ |> GEN “z:real”) + val validHyp = specThm |> UNDISCH_ALL |> hyp |> hd |> EVAL |> SIMP_RULE std_ss [EQ_CLAUSES] +in +Theorem REAL_LT_DIV_EQ[local] = MATCH_MP specThm validHyp; +end + +fun mk_pi_lb_thm cval iters = let + fun revApp f x = fn y => f y x + val abs_9 = EVAL “abs ^cval < 1” |> SIMP_RULE std_ss [EQ_CLAUSES] + val atnPoly_eq = EVAL “evalPoly (atnPoly ^iters) ^cval” + val ERR_ATN = EVAL “abs ^cval pow ^iters / (1 - abs ^cval)” + val ATN_CONCR_LT_PI4 = MATCH_MP (Q.SPEC ‘^cval’ ATN_LT_PI4_POS) (EVAL “^cval < 1” |> SIMP_RULE std_ss [EQ_CLAUSES]) + in + REWRITE_RULE [GSYM atnPoly_correct] MCLAURIN_ATN + |> SPEC_ALL |> GEN “x:real” |> GEN “n:num” + |> SPEC “^iters:num” + |> SPEC “^cval:real” + |> (fn th => MATCH_MP th abs_9) + |> REWRITE_RULE [atnPoly_eq, ERR_ATN] + |> MATCH_MP ERR_ABS_SIMP + |> CONJ_LIST 4 |> (fn ls => List.nth (ls, 3)) + |> MATCH_MP (REWRITE_RULE [GSYM AND_IMP_INTRO] REAL_LET_TRANS) + |> revApp MATCH_MP ATN_CONCR_LT_PI4 + |> REWRITE_RULE [REAL_LT_DIV_EQ] + |> CONV_RULE $ RATOR_CONV $ RAND_CONV EVAL + end; + +Theorem PI_LB = mk_pi_lb_thm “0.97:real” “150:num” + +Theorem inv2_le_pi2: + inv 2 ≤ pi/2 +Proof + ‘2 * inv 2 ≤ pi’ suffices_by gs[] + >> rewrite_tac[REAL_INV_1OVER] + >> ‘2 * (1 / 2) = 1:real’ by EVAL_TAC + >> pop_assum $ rewrite_tac o single + >> ‘1 < pi’ suffices_by real_tac + >> irule REAL_LET_TRANS + >> qexists_tac ‘^(PI_LB|> concl |> rator |> rand)’ + >> gs[PI_LB] +QED + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/moreRealScript.sml b/floatingPoint/tools/dandelion/moreRealScript.sml new file mode 100644 index 0000000000..10648eb9ec --- /dev/null +++ b/floatingPoint/tools/dandelion/moreRealScript.sml @@ -0,0 +1,676 @@ +(** + small theorems extending HOL4's realTheory + used throughout the development +**) +open preambleDandelion; + +val _ = new_theory "moreReal"; + +val _ = realLib.deprecate_real(); + +Theorem REAL_LE_RCANCEL_IMP: + ∀ x y z:real. + &0 < z ∧ + x * z ≤ y * z ⇒ + x ≤ y +Proof + rpt strip_tac + >> gs[REAL_LE_LMUL] +QED + +Theorem diff_chain: + ∀ x. ((λx. 1 + x) diffl 1) x +Proof + rpt strip_tac + >> ‘& 1 = &0 + &1’ by gs[] + >> ‘(λx. 1 + x) = (λx. ((\x. 1) x) + ((\x. x) x))’ by gs[FUN_EQ_THM] + >> ‘ ((λx. ((\x. 1) x) + ((\x. x) x)) diffl (&0 + &1)) x ==> + ((λx. 1 + x) diffl 1) x ’ by gs[] + >> first_assum irule + >> irule limTheory.DIFF_ADD + >> rpt conj_tac + >- rewrite_tac[limTheory.DIFF_CONST] + >> rewrite_tac[limTheory.DIFF_X] +QED + +Theorem diff_chain_sub: + ∀ x. ((λx. 1 - x) diffl -1) x +Proof + rpt strip_tac + >> ‘-1 = &0 -1’ by gs[] + >> ‘(λx:real. 1 - x) = (λx. ((\x. 1) x) + ((\x. -x) x))’ by + ( rw[FUN_EQ_THM] >> REAL_ARITH_TAC ) + >> ‘ ((λx:real. ((\x. 1) x) + ((\x:real. -x) x)) diffl (&0 + -1)) x ==> + ((λx:real. 1 - x) diffl -1) x ’ by gs[] + >> first_assum irule + >> irule limTheory.DIFF_ADD + >> rpt conj_tac + >- rewrite_tac[limTheory.DIFF_CONST] + >> ‘ ((λx. (-1) * ((\x. x) x)) diffl ((-1) * &1)) x ==> + ((λx:real. -x) diffl -1) x’ by rw[] + >> first_assum irule + >> irule limTheory.DIFF_CMUL + >> rewrite_tac[limTheory.DIFF_X] +QED + +Theorem cos_lt_1: + !x. 0 < x /\ x < (pi / &2) ==> + cos x < 1 +Proof + rpt strip_tac + >> ‘!a:bool. a = ~~a’ by gs[] + >> pop_assum $ once_rewrite_tac o single + >> PURE_ONCE_REWRITE_TAC[REAL_NOT_LT] + >> DISCH_THEN(MP_TAC o MATCH_MP REAL_LE1_POW2) + >> DISCH_THEN(MP_TAC o ONCE_REWRITE_RULE[GSYM REAL_SUB_LE]) + >> DISCH_THEN(MP_TAC o CONJ(SPEC “sin(x)” REAL_LE_SQUARE)) + >> REWRITE_TAC[GSYM POW_2] + >> rw[] + >> rewrite_tac[GSYM SIN_CIRCLE] + >> ‘(cos x)² - ((sin x)² + (cos x)²) = - ((sin x) pow 2)’ by + REAL_ARITH_TAC + >> pop_assum $ rewrite_tac o single + >> gs[] + >> assume_tac REAL_NOT_LE + >> pop_assum $ qspecl_then [‘(sin x) pow 2’, ‘&0’] assume_tac + >> pop_assum $ rewrite_tac o single + >> irule REAL_POW_LT + >> gs[SIN_POS_PI2] +QED + +Theorem DIFF_DEC_LT: + ∀ f x lo hi. + lo < x ∧ x < hi ∧ + (∀ z. lo ≤ z ∧ z ≤ hi ⇒ f contl z) ∧ + (∀ z. ∃ l. lo < z ∧ z < hi ⇒ (f diffl l) z ∧ l < 0) ⇒ + (∀ y. lo < y ∧ y < hi ∧ x < y ⇒ f y < f x) +Proof + rpt strip_tac + >> qspecl_then [‘f’, ‘x’, ‘y’] mp_tac limTheory.MVT >> impl_tac + >- ( + rpt conj_tac + >- gs[] + >- ( + rpt strip_tac >> rename [‘z <= y’] + >> first_x_assum irule >> conj_tac >> real_tac) + >> rpt strip_tac >> rename [‘z < y’] + >> ‘lo < z /\ z < hi’ by (conj_tac >> real_tac) + >> first_x_assum $ qspec_then ‘z’ strip_assume_tac + >> res_tac >> rewrite_tac[limTheory.differentiable] + >> qexists_tac ‘l’ >> gs[]) + >> rpt strip_tac + >> ‘lo < z /\ z < hi’ by (conj_tac >> real_tac) + >> first_x_assum $ qspec_then ‘z’ strip_assume_tac + >> res_tac + >> ‘l = l'’ + by (irule limTheory.DIFF_UNIQ >> qexists_tac ‘f’ >> qexists_tac ‘z’ >> res_tac >> gs[]) + >> rpt VAR_EQ_TAC + >> ‘0 < y - x’ by real_tac + >> Cases_on ‘l = 0’ >- (rpt VAR_EQ_TAC >> real_tac) + >> ‘l < 0’ by real_tac + >> ‘(y - x) * l < 0’ suffices_by real_tac + >> ‘0:real = (y - x) * 0’ by real_tac + >> pop_assum $ once_rewrite_tac o single + >> irule REAL_LT_LMUL_IMP >> gs[] +QED + +Theorem DIFF_DEC_LE: + ∀ f x lo hi. + lo ≤ x ∧ x ≤ hi ∧ + (∀ z. ∃ l. lo ≤ z ∧ z ≤ hi ⇒ (f diffl l) z ∧ l ≤ 0) ⇒ + (∀ y. lo ≤ y ∧ y ≤ hi ∧ x ≤ y ⇒ f y ≤ f x) +Proof + rpt strip_tac + >> Cases_on ‘x = y’ >- gs[] + >> ‘x < y’ by real_tac + >> qspecl_then [‘f’, ‘x’, ‘y’] mp_tac limTheory.MVT >> impl_tac + >- ( + rpt conj_tac + >- gs[] + >- ( + rpt strip_tac >> rename [‘z <= y’] + >> ‘lo <= z /\ z <= hi’ by (conj_tac >> real_tac) + >> irule limTheory.DIFF_CONT + >> first_x_assum $ qspec_then ‘z’ strip_assume_tac + >> res_tac >> qexists_tac ‘l’ >> gs[]) + >> rpt strip_tac >> rename [‘z < y’] + >> ‘lo <= z /\ z <= hi’ by (conj_tac >> real_tac) + >> first_x_assum $ qspec_then ‘z’ strip_assume_tac + >> res_tac >> rewrite_tac[limTheory.differentiable] + >> qexists_tac ‘l’ >> gs[]) + >> rpt strip_tac + >> ‘lo <= z /\ z <= hi’ by (conj_tac >> real_tac) + >> first_x_assum $ qspec_then ‘z’ strip_assume_tac + >> res_tac + >> ‘l = l'’ + by (irule limTheory.DIFF_UNIQ >> qexists_tac ‘f’ >> qexists_tac ‘z’ >> gs[]) + >> rpt VAR_EQ_TAC + >> ‘0 < y - x’ by real_tac + >> Cases_on ‘l = 0’ >- (rpt VAR_EQ_TAC >> real_tac) + >> ‘l < 0’ by real_tac + >> ‘(y - x) * l < 0’ suffices_by real_tac + >> ‘0:real = (y - x) * 0’ by real_tac + >> pop_assum $ once_rewrite_tac o single + >> irule REAL_LT_LMUL_IMP >> gs[] +QED + +Theorem DIFF_INC: + ∀ f x lo hi. + lo ≤ x ∧ x ≤ hi ∧ + (∀ z. ∃ l. lo ≤ z ∧ z ≤ hi ⇒ (f diffl l) z ∧ 0 ≤ l) ⇒ + (∀ y. lo ≤ y ∧ y ≤ hi ∧ x ≤ y ⇒ f x ≤ f y) +Proof + rpt strip_tac + >> Cases_on ‘x = y’ >- gs[] + >> ‘x < y’ by real_tac + >> qspecl_then [‘f’, ‘x’, ‘y’] mp_tac limTheory.MVT + >> impl_tac + >- ( + rpt conj_tac + >- gs[] + >- ( + rpt strip_tac >> rename [‘z <= y’] + >> ‘lo <= z /\ z <= hi’ by (conj_tac >> real_tac) + >> irule limTheory.DIFF_CONT + >> first_x_assum $ qspec_then ‘z’ strip_assume_tac + >> res_tac >> qexists_tac ‘l’ >> gs[]) + >> rpt strip_tac >> rename [‘z < y’] + >> ‘lo <= z /\ z <= hi’ by (conj_tac >> real_tac) + >> first_x_assum $ qspec_then ‘z’ strip_assume_tac + >> res_tac >> rewrite_tac[limTheory.differentiable] + >> qexists_tac ‘l’ >> gs[]) + >> rpt strip_tac + >> ‘lo <= z /\ z <= hi’ by (conj_tac >> real_tac) + >> first_x_assum $ qspec_then ‘z’ strip_assume_tac + >> res_tac + >> ‘l = l'’ + by (irule limTheory.DIFF_UNIQ >> qexists_tac ‘f’ >> qexists_tac ‘z’ >> gs[]) + >> rpt VAR_EQ_TAC + >> Cases_on ‘l = 0’ + >- (rpt VAR_EQ_TAC >> real_tac) + >> ‘0 < l’ by real_tac + >> ‘0 < y - x’ by real_tac + >> ‘0 < (y - x) * l’ suffices_by real_tac + >> irule REAL_LT_MUL >> gs[] +QED + +Theorem REAL_LE_ZERO_MUL1: + ∀ x (y:real). + x ≤ 0 ∧ 0 ≤ y ⇒ x * y ≤ 0 +Proof + rpt strip_tac + >> transitivity_for ‘0 * y’ >> reverse conj_tac + >- real_tac + >> irule REAL_LE_RMUL_IMP >> gs[] +QED + +Theorem REAL_LE_ZERO_MUL2: + ∀ x (y:real). + 0 ≤ x ∧ y ≤ 0 ⇒ x * y ≤ 0 +Proof + rpt strip_tac + >> transitivity_for ‘x * 0’ >> reverse conj_tac + >- real_tac + >> irule REAL_LE_LMUL_IMP >> gs[] +QED + +Theorem REAL_ZERO_LE_MUL1: + ∀ x (y:real). + 0 ≤ x ∧ 0 ≤ y ⇒ 0 ≤ x * y +Proof + rpt strip_tac + >> transitivity_for ‘0 * 0’ >> conj_tac + >- real_tac + >> irule REAL_LE_MUL2 >> gs[] +QED + +Theorem REAL_ZERO_LE_MUL2: + ∀ x (y:real). + x ≤ 0 ∧ y ≤ 0 ⇒ 0 ≤ x * y +Proof + rpt strip_tac + >> ‘0 ≤ -x’ by real_tac + >> ‘0 ≤ -y’ by real_tac + >> ‘x * y = - - (x * y)’ by real_tac + >> pop_assum $ once_rewrite_tac o single + >> rewrite_tac[Once REAL_NEG_LMUL, Once REAL_NEG_RMUL] + >> irule REAL_ZERO_LE_MUL1 >> gs[] +QED + +Theorem REAL_NEG_LE1: + - y ≤ x ⇒ - x ≤ y:real +Proof + rpt strip_tac + >> ‘y = - - y’ by real_tac + >> pop_assum $ once_rewrite_tac o single + >> gs[REAL_LE_NEG] +QED + +Theorem REAL_NEG_LE2: + y ≤ - x ⇒ x ≤ -y:real +Proof + rpt strip_tac + >> ‘x = - - x’ by real_tac + >> pop_assum $ once_rewrite_tac o single + >> gs[REAL_LE_NEG] +QED + +Theorem MVT_ALT: + ∀ f f' a b. + a < b ∧ (∀ x. a ≤ x ∧ x ≤ b ⇒ (f diffl f'(x))(x)) ⇒ + ∃ z. a < z ∧ z < b ∧ (f b - f a = (b - a) * f'(z)) +Proof + rpt strip_tac + >> drule limTheory.MVT >> rewrite_tac[limTheory.differentiable] + >> disch_then $ qspec_then ‘f’ mp_tac >> impl_tac + >- ( + rpt conj_tac >> rpt strip_tac >> res_tac + >- drule_then MATCH_ACCEPT_TAC limTheory.DIFF_CONT + >> qexists_tac ‘f' x’ >> first_x_assum irule + >> gs[REAL_LT_IMP_LE]) + >> rpt strip_tac + >> ‘(f diffl f' z) z’ by (first_x_assum irule >> gs[REAL_LT_IMP_LE]) + >> ‘f' z = l’ + by (drule limTheory.DIFF_UNIQ >> disch_then $ qspec_then ‘l’ mp_tac >> gs[]) + >> rpt VAR_EQ_TAC + >> qexists_tac ‘z’ >> gs[] +QED + +(** intervals where cosine is negative **) + +Theorem cos_pi2_pi_le: + ∀ x. + pi / 2 ≤ x ∧ x ≤ pi ⇒ + cos x ≤ 0 +Proof + rpt strip_tac >> Cases_on ‘x = pi/2’ + >- (VAR_EQ_TAC >> gs[COS_PI2]) + >> ‘pi/2 < x’ by real_tac + >> qspecl_then [‘cos’, ‘λ x. - sin x’, ‘pi/2’, ‘x’] mp_tac MVT_ALT + >> impl_tac + >- gs[BETA_THM, DIFF_COS] + >> BETA_TAC >> rewrite_tac[COS_PI2, REAL_SUB_RZERO] + >> rpt strip_tac + >> pop_assum $ rewrite_tac o single + >> irule REAL_LE_ZERO_MUL2 >> reverse conj_tac + >- real_tac + >> rewrite_tac[REAL_NEG_LE0] + >> irule SIN_POS_PI_LE >> conj_tac + >- (transitivity_for ‘x’ >> gs[REAL_LE_LT]) + >> transitivity_for ‘pi/2’ >> gs[REAL_LE_LT, PI2_BOUNDS] +QED + +Theorem cos_negpi_negpi2_le: + ∀ x. + - pi ≤ x ∧ x ≤ - (pi / 2) ⇒ + cos x ≤ 0 +Proof + rpt strip_tac >> Cases_on ‘- (pi/2) = x’ + >- (VAR_EQ_TAC >> gs[COS_NEG, COS_PI2]) + >> ‘x < - (pi / 2)’ by real_tac + >> qspecl_then [‘cos’, ‘λ x. - sin x’, ‘x’, ‘- (pi/2)’] mp_tac MVT_ALT + >> impl_tac + >- gs[BETA_THM, DIFF_COS] + >> BETA_TAC >> rewrite_tac[COS_PI2, COS_NEG, REAL_SUB_LZERO] + >> rpt strip_tac + >> ‘0:real = -0’ by real_tac + >> pop_assum $ once_rewrite_tac o single + >> irule REAL_NEG_LE2 + >> pop_assum $ rewrite_tac o single + >> irule REAL_LE_MUL >> conj_tac + >- real_tac + >> rewrite_tac[GSYM SIN_NEG] + >> ‘pi/2 ≤ - z’ by real_tac + >> ‘-z ≤ pi’ by real_tac + >> irule SIN_POS_PI_LE >> conj_tac >- gs[] + >> transitivity_for ‘pi/2’ >> gs[REAL_LE_LT, PI2_BOUNDS] +QED + +(** intervals where sine is negative**) + +Theorem SIN_NEGPI: + sin (- pi) = 0 +Proof + gs[SIN_NEG, SIN_PI] +QED + +Theorem SIN_NEGPI2: + sin (- (pi/2)) = -1 +Proof + gs[SIN_NEG, SIN_PI2] +QED + +Theorem sin_negpi2_0_le: + ∀ x. + - (pi/2) ≤ x ∧ x ≤ 0 ⇒ + sin x ≤ 0 +Proof + rpt strip_tac >> Cases_on ‘x = 0’ + >- gs[SIN_0] + >> ‘x < 0’ by real_tac + >> qspecl_then [‘sin’, ‘cos’, ‘x’, ‘0’] mp_tac MVT_ALT + >> impl_tac + >- gs[BETA_THM, DIFF_SIN] + >> BETA_TAC >> rewrite_tac[SIN_0, REAL_SUB_LZERO] + >> rpt strip_tac + >> ‘0 = - 0:real’ by real_tac + >> pop_assum $ once_rewrite_tac o single + >> irule REAL_NEG_LE2 + >> pop_assum $ once_rewrite_tac o single + >> rewrite_tac [GSYM REAL_NEG_LMUL] + >> irule REAL_NEG_LE2 >> real_rw ‘- 0 = 0:real’ + >> irule REAL_LE_ZERO_MUL1 >> conj_tac + >- real_tac + >> irule COS_POS_PI_LE >> conj_tac + >- (transitivity_for ‘0’ >> gs[REAL_LE_LT, PI2_BOUNDS]) + >> transitivity_for ‘x’ >> gs[REAL_LE_LT] +QED + +Theorem sin_negpi_negpi2_le: + ∀ x. + - pi ≤ x ∧ x ≤ - (pi / 2) ⇒ + sin x ≤ 0 +Proof + rpt strip_tac >> Cases_on ‘x = - pi’ + >- (VAR_EQ_TAC >> gs[SIN_NEGPI]) + >> ‘- pi < x ’ by real_tac + >> qspecl_then [‘sin’, ‘cos’, ‘- pi’, ‘x’] mp_tac MVT_ALT + >> impl_tac + >- gs[BETA_THM, DIFF_SIN] + >> BETA_TAC >> rewrite_tac[SIN_NEGPI, REAL_SUB_RZERO] + >> rpt strip_tac + >> pop_assum $ once_rewrite_tac o single + >> irule REAL_LE_ZERO_MUL2 >> reverse conj_tac + >- real_tac + >> irule cos_negpi_negpi2_le >> conj_tac + >- (transitivity_for ‘x’ >> gs[REAL_LE_LT]) + >> gs[REAL_LE_LT] +QED + +Theorem sin_negpi_0_le: + ∀ x. + - pi ≤ x ∧ x ≤ 0 ⇒ + sin x ≤ 0 +Proof + rpt strip_tac >> Cases_on ‘x ≤ - (pi / 2)’ + >- (irule sin_negpi_negpi2_le >> gs[]) + >> irule sin_negpi2_0_le + >> gs[REAL_NOT_LE, REAL_LE_LT] +QED + +(** monotonicity of cosine **) + +Theorem cos_incr_negpi_0: + ∀ x y. + - pi ≤ x ∧ x ≤ 0 ∧ + - pi ≤ y ∧ y ≤ 0 ∧ + x ≤ y ⇒ + cos x ≤ cos y +Proof + rpt strip_tac >> irule DIFF_INC >> conj_tac >- gs[] + >> qexists_tac ‘0’ >> qexists_tac ‘- pi’ + >> reverse conj_tac >- gs[] + >> rpt strip_tac >> qexists_tac ‘- sin z’ + >> gs[DIFF_COS, sin_negpi_0_le] +QED + +Theorem cos_decr_0_pi: + ∀ x y. + 0 ≤ x ∧ x ≤ pi ∧ + 0 ≤ y ∧ y ≤ pi ∧ + x ≤ y ⇒ + cos y ≤ cos x +Proof + rpt strip_tac >> irule DIFF_DEC_LE >> conj_tac >- gs[] + >> qexists_tac ‘pi’ >> qexists_tac ‘0’ + >> reverse conj_tac >- gs[] + >> rpt strip_tac >> qexists_tac ‘- sin z’ + >> gs[DIFF_COS, SIN_POS_PI_LE] +QED + +Theorem cos_decr_0_pi_lt: + ∀ x y. + 0 < x ∧ x < pi ∧ + 0 < y ∧ y < pi ∧ + x < y ⇒ + cos y < cos x +Proof + rpt strip_tac >> irule DIFF_DEC_LT >> conj_tac >- gs[] + >> qexists_tac ‘pi’ >> qexists_tac ‘0’ + >> conj_tac + >- ( + rpt strip_tac >> qexists_tac ‘- sin z’ + >> gs[DIFF_COS, SIN_POS_PI]) + >> reverse conj_tac >- gs[] + >> rpt strip_tac >> irule limTheory.DIFF_CONT + >> qexists_tac ‘- sin z’ >> gs[DIFF_COS] +QED + +Theorem sin_incr_0_pi2: + ∀ x y. + 0 ≤ x ∧ x ≤ pi/2 ∧ + 0 ≤ y ∧ y ≤ pi/2 ∧ + x ≤ y ⇒ + sin x ≤ sin y +Proof + rpt strip_tac >> irule DIFF_INC >> conj_tac >- gs[] + >> qexists_tac ‘pi/2’ >> qexists_tac ‘0’ >> reverse conj_tac + >- gs[] + >> gen_tac >> qexists_tac ‘cos z’ + >> rpt strip_tac >- gs[DIFF_SIN] + >> irule COS_POS_PI2_LE >> gs[] +QED + +Theorem sin_incr_negpi2_0: + ∀ x y. + - pi / 2 ≤ x ∧ x ≤ 0 ∧ + - pi / 2 ≤ y ∧ y ≤ 0 ∧ + x ≤ y ⇒ + sin x ≤ sin y +Proof + rpt strip_tac >> qspecl_then [‘-y’, ‘-x’] mp_tac sin_incr_0_pi2 + >> impl_tac + >> gs[REAL_NEG_LE1, SIN_NEG] +QED + +Theorem sin_decr_pi2_pi: + ∀ x y. + pi/2 ≤ x ∧ x ≤ pi ∧ + pi/2 ≤ y ∧ y ≤ pi ∧ + x ≤ y ⇒ + sin y ≤ sin x +Proof + rpt strip_tac >> irule DIFF_DEC_LE >> conj_tac >- gs[] + >> qexists_tac ‘pi’ >> qexists_tac ‘pi / 2’ >> reverse conj_tac + >- gs[] + >> gen_tac >> qexists_tac ‘cos z’ + >> rpt strip_tac >- gs[DIFF_SIN] + >> irule cos_pi2_pi_le >> gs[] +QED + +Theorem sin_decr_negpi_negpi2: + ∀ x y. + - pi ≤ x ∧ x ≤ - (pi/2) ∧ + - pi ≤ y ∧ y ≤ - (pi/2) ∧ + x ≤ y ⇒ + sin y ≤ sin x +Proof + rpt strip_tac >> qspecl_then [‘-y’, ‘-x’] mp_tac sin_decr_pi2_pi + >> impl_tac + >> rpt conj_tac >> gs[REAL_NEG_LE1, REAL_NEG_LE2, SIN_NEG] +QED + +Theorem cos_decreasing: + ∀ x y. + 0 < x ∧ x < pi ∧ + 0 < y ∧ y < pi ∧ + cos x ≤ cos y ⇒ + y ≤ x +Proof + rpt strip_tac >> CCONTR_TAC >> gs[REAL_NOT_LE] + >> qspecl_then [‘x’, ‘y’] mp_tac cos_decr_0_pi_lt + >> impl_tac >- gs[] + >> strip_tac >> real_tac +QED + +Theorem PI2_lt_PI: + (pi / &2) < pi +Proof + gs[] + >> ‘0 < pi ==> pi < 2 * pi’ by REAL_ARITH_TAC + >> first_assum irule + >> gs[PI_POS] +QED + +Theorem ATN_0: + atn(&0) = &0 +Proof + ‘atn(&0) = atn(tan(&0))’ by + ( ‘tan(&0) = &0’ by gs[TAN_0] + >> gs[] + ) + >> pop_assum $ rewrite_tac o single + >> irule TAN_ATN + >> gs[PI_POS] +QED + +Theorem DIFF_ISCONST_END_SIMPLE: + !f a b. a < b /\ + (!x. a <= x /\ x <= b ==> (f diffl &0)(x)) + ==> (f b = f a) +Proof + REPEAT STRIP_TAC THEN MATCH_MP_TAC limTheory.DIFF_ISCONST_END THEN + mesonLib.ASM_MESON_TAC[limTheory.DIFF_CONT, REAL_LT_IMP_LE] +QED + +Theorem ERR_ABS_SIMP: + abs (a - b) <= err ==> + b <= a + err /\ + a - err <= b /\ + a <= b + err /\ + b - err <= a +Proof + strip_tac >> rpt conj_tac >> real_tac +QED + +Theorem EXP_MINUS_ONE_POS: + ! x. 0 <= x ==> + 0 <= exp x - 1 +Proof + rpt strip_tac + >> gs[REAL_SUB_LE] + >> transitivity_for ‘exp 0’ + >> gs[EXP_0, EXP_MONO_LE] +QED + +(** Ported from HOL-Light **) +Theorem TAN_PI4: + tan(pi / &4) = &1 +Proof + REWRITE_TAC[tan, COS_SIN, real_div, GSYM REAL_SUB_LDISTRIB] >> gs[] + >> once_rewrite_tac [REAL_MUL_SYM] + >> rewrite_tac [REAL_INV_1OVER] + >> rewrite_tac[EVAL “1 / 2 - 1 / (4:real)”] + >> rewrite_tac [GSYM REAL_INV_1OVER] + >> ‘inv 4 * pi = pi * inv 4’ by gs[] + >> pop_assum $ rewrite_tac o single + >> irule REAL_MUL_RINV + >> rewrite_tac[SIN_ZERO] + >> rewrite_tac[real_div, GSYM REAL_MUL_LNEG] + >> simp[REAL_MUL_LID, REAL_EQ_MUL_LCANCEL, PI_POS] + >> rpt strip_tac + >> ‘0 < pi / 2’ by gs[PI2_BOUNDS] + >> ‘0 < pi’ by gs[] + >> gs[] +QED + +Theorem ATN_1: + atn(&1) = pi / &4 +Proof + MP_TAC(AP_TERM “atn” TAN_PI4) + >> DISCH_THEN(SUBST1_TAC o SYM) + >> irule TAN_ATN + >> gs[PI2_BOUNDS] >> conj_tac >> gs[PI_POS] +QED + +Theorem ATN_MONO_LT: + ∀ x y. x < y ⇒ atn x < atn y +Proof + rpt strip_tac + >> qspecl_then [‘atn’, ‘λ x. inv (1 + x pow 2)’, ‘x’, ‘y’] mp_tac MVT_ALT + >> BETA_TAC >> gs[DIFF_ATN] + >> strip_tac + >> FIRST_ASSUM(MATCH_MP_TAC o MATCH_MP (REAL_ARITH + “(l:real - r = d) ==> l < d + e ==> r < e”)) + >> REWRITE_TAC[REAL_ARITH “a < b + a <=> &0 < b:real”] + >> MATCH_MP_TAC REAL_LT_MUL + >> ASM_REWRITE_TAC[REAL_LT_SUB_LADD, REAL_ADD_LID] + >> REWRITE_TAC[REAL_LT_INV_EQ] + >> MATCH_MP_TAC(REAL_ARITH “&0 <= x ==> &0 < &1 + x:real”) + >> REWRITE_TAC[POW_2, REAL_LE_SQUARE] +QED + +Theorem ATN_NEG: + ∀ x. atn(-x) = -(atn x) +Proof + GEN_TAC THEN MP_TAC(Q.SPEC `atn(x)` TAN_NEG) THEN + REWRITE_TAC[ATN_TAN] THEN DISCH_THEN(SUBST1_TAC o SYM) THEN + MATCH_MP_TAC TAN_ATN THEN + MATCH_MP_TAC(REAL_ARITH + “-a < x /\ x < a ⇒ -a < -x ∧ -x < a:real”) THEN + REWRITE_TAC[ATN_BOUNDS] +QED + +Theorem ATN_LT_PI4_POS: + ∀ x. x < &1 ⇒ atn(x) < pi / &4 +Proof + rewrite_tac [GSYM ATN_1] + >> gs[ATN_MONO_LT] +QED + +Theorem ATN_LT_PI4_NEG: + ∀ x. -(&1) < x ⇒ -(pi / &4) < atn(x) +Proof + rewrite_tac [GSYM ATN_1, GSYM ATN_NEG] + >> gs[ATN_MONO_LT] +QED + +Theorem abs_exists: + abs (x - y) ≤ eps ⇒ + ∃ d. y = x + d ∧ abs d ≤ eps +Proof + rpt strip_tac + >> qexists_tac ‘y - x’ >> conj_tac >> real_tac +QED + +Theorem pow_simp: + x * x = x pow 2 /\ x pow n * x = x pow (SUC n) +Proof + gs[pow] +QED + +Theorem REAL_ABS_TRIANGLE_PRE: + ! (lb:real) ub tr p1 p2 v err1 err2. + (! x. lb <= x /\ x <= ub ==> abs (optionGet (interp tr [(v, x)]) - evalPoly p1 x) <= err1) ==> + (! x. lb <= x /\ x <= ub ==> abs (evalPoly p1 x - evalPoly p2 x) <= err2) ==> + (! x. lb <= x /\ x <= ub ==> abs (optionGet (interp tr [(v, x)]) - evalPoly p2 x) <= err1 + err2) +Proof + rpt strip_tac >> res_tac + >> ntac 2 $ pop_assum mp_tac + >> qmatch_goalsub_abbrev_tac ‘abs (r2 - r3) <= err2’ >> strip_tac + >> qmatch_goalsub_abbrev_tac ‘abs (r1 - r2) <= err1’ >> strip_tac + >> ‘r1 - r3 = (r1 - r2) + (r2 - r3)’ by real_tac + >> pop_assum $ rewrite_tac o single + >> transitivity_for ‘abs (r1 - r2) + abs (r2 - r3)’ + >> gs[REAL_ABS_TRIANGLE] >> irule REAL_LE_ADD2 + >> gs[] +QED + +Theorem IMP_SPLIT: +(! x. xlo <= x /\ x <= xhi ==> (P x /\ Q x)) <=> +((! x. xlo <= x /\ x <= xhi ==> P x) /\ (! x. xlo <= x /\ x <= xhi ==> Q x)) +Proof + rpt strip_tac >> EQ_TAC >> rpt strip_tac >> res_tac >> gs[] +QED + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/pointCheckerProofsScript.sml b/floatingPoint/tools/dandelion/pointCheckerProofsScript.sml new file mode 100644 index 0000000000..dd10c7db48 --- /dev/null +++ b/floatingPoint/tools/dandelion/pointCheckerProofsScript.sml @@ -0,0 +1,42 @@ +(** + Soundness theorem of the point-wise equivalence checker + Currently unused +**) +open realTheory realLib RealArith stringTheory; +open renameTheory realPolyTheory checkerDefsTheory pointCheckerTheory; +open realPolyProofsTheory; +open preambleDandelion; + +val _ = new_theory "pointCheckerProofs"; + +(* +Theorem pointChecker_intermed: + ∀ omega transc poly eps. + pointCheckerHelper omega transc poly eps = Valid ⇒ + ∀xi. + MEM xi omega ⇒ + abs (evalPoly poly xi − transc xi) = eps + +Proof + Induct_on ‘omega’ + >> gs[pointCheckerHelper_def] + >> rpt strip_tac + >> every_case_tac >> gs[] +QED + +Theorem pointCheckerSound: + ∀ (cert:certificate). + pointChecker cert = Valid ⇒ + ∀ xi. + MEM xi cert.omega ⇒ + abs ((evalPoly cert.poly xi) - (λ x. interp cert.transc x) xi) = cert.eps +Proof + gs[pointChecker_def] + >> rpt gen_tac >> cond_cases_tac >> gs[] + >> rpt strip_tac + >> drule pointChecker_intermed + >> rpt $ disch_then drule >> gs[] +QED +*) + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/pointCheckerScript.sml b/floatingPoint/tools/dandelion/pointCheckerScript.sml new file mode 100644 index 0000000000..27980ef776 --- /dev/null +++ b/floatingPoint/tools/dandelion/pointCheckerScript.sml @@ -0,0 +1,34 @@ +(** + A simple checker for polynomial evaluation + Part one of the soundness proof requires showing that the approximated + polynomial agrees with what Remez thought the trancendental function behaves + like on the set of points Ω + + Currently not used in Dandelion +**) + +open realTheory realLib RealArith stringTheory; +open renameTheory realPolyTheory transcLangTheory checkerDefsTheory; +open preambleDandelion; + +val _ = new_theory "pointChecker"; + +(* +(* TODO: Check for each xi in Omega that p(xi) - f(xi) = cert.eps *) + +Definition pointCheckerHelper_def: + pointCheckerHelper [] transc poly eps = Valid ∧ + pointCheckerHelper (x1::xs) transc poly eps = + if (abs (evalPoly poly x1 - transc x1) = eps) + then (pointCheckerHelper xs transc poly eps) + else Invalid "Point discrepancy" +End + +Definition pointChecker_def: + pointChecker (cert:certificate): result = + if (LENGTH cert.omega = 0) then Invalid "Empty set" else + (pointCheckerHelper cert.omega (λ x. interp cert.transc x) cert.poly cert.eps) +End +*) + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/preambleDandelion.sml b/floatingPoint/tools/dandelion/preambleDandelion.sml new file mode 100644 index 0000000000..700de96995 --- /dev/null +++ b/floatingPoint/tools/dandelion/preambleDandelion.sml @@ -0,0 +1,53 @@ +(** + Proof tools (e.g. tactics) used throughout the development. + Copied from CakeML (https://github.com/CakeML/cakeml) +**) +structure preambleDandelion = +struct +local open intLib in end; +open set_relationTheory; (* comes first so relationTheory takes precedence *) +open ASCIInumbersTheory BasicProvers Defn HolKernel Parse SatisfySimps Tactic + monadsyntax alistTheory alignmentTheory arithmeticTheory bagTheory boolLib + boolSimps bossLib containerTheory combinTheory dep_rewrite + finite_mapTheory indexedListsTheory listTheory llistTheory (* lcsymtacs *) + markerLib mp_then optionTheory pairLib + pairTheory pred_setTheory quantHeuristicsLib relationTheory res_quanTheory + rich_listTheory sortingTheory sptreeTheory stringTheory sumTheory + realTheory realLib RealArith transcTheory; + +(* TOOD: move? *) +val wf_rel_tac = WF_REL_TAC +val sym_sub_tac = SUBST_ALL_TAC o SYM; +val match_exists_tac = part_match_exists_tac (hd o strip_conj) +val asm_exists_tac = first_assum(match_exists_tac o concl) +val cond_cases_tac = COND_CASES_TAC +val top_case_tac = TOP_CASE_TAC +val real_tac = rpt (qpat_x_assum ‘! x. _’ kall_tac) >> REAL_ASM_ARITH_TAC +val eq_tac = EQ_TAC +val eval_tac = EVAL_TAC +fun impl_subgoal_tac th = + let + val hyp_to_prove = lhand (concl th) + in + SUBGOAL_THEN hyp_to_prove (fn thm => assume_tac (MP th thm)) + end; + +fun real_prove_rw_tac (t:Q.tmquote) (rw:thm list -> tactic) = + t by real_tac >> pop_assum $ rw o single + +val real_rw = fn (t:Q.tmquote) => real_prove_rw_tac t rewrite_tac + +val real_once_rw = fn (t:Q.tmquote) => real_prove_rw_tac t once_rewrite_tac + +fun transitivity_for t = + (irule REAL_LE_TRANS ORELSE irule REAL_LT_TRANS) >> qexists_tac t + +fun mp_with_then tac t1 ith = + qpat_assum t1 ( fn th => tac (MATCH_MP ith th)); + +fun mpx_with_then tac t1 ith = + qpat_x_assum t1 ( fn th => tac (MATCH_MP ith th)); + +val _ = set_trace"Goalstack.print_goal_at_top"0 handle HOL_ERR _ => set_trace"goalstack print goal at top"0 + +end; diff --git a/floatingPoint/tools/dandelion/readmePrefix b/floatingPoint/tools/dandelion/readmePrefix new file mode 100644 index 0000000000..34a61bacf3 --- /dev/null +++ b/floatingPoint/tools/dandelion/readmePrefix @@ -0,0 +1,43 @@ +# Dandelion + +A certificate checker for approximations of elementary functions. + +## Key theorems and definitions relating to the original ITP'22 paper + +The first phase is defined across the files `transcApproxSemScript.sml` and +`approxPolyScript.sml`. The first file defines the overall approximation +function `approxAsPoly` and gives its soundness proof, and +`approxPolyScript.sml` defines the low-level approximation function for +approximating a single elementary function with a single polynomial and proves +soundness of this function. + +Theorem 4 (First Phase Soundness) from section 3 is proven in file +`transcApproxSemScript.sml` as `approxTransc_sound`. +Variants of Theorem 5 are proven for the supported elementary function in file +`mcLaurinApproxScript.sml` if they are not provided by HOL4. +Variants of Theorem 6 are proven for the supported elementary functions in file +`approxPolyScript.sml`. + +The second phase is implemented and proven sound in the file +`checkerScript.sml`. +It relies on the implementation of computable Sturm sequences in +`sturmComputeScript.sml` and computable polynomial division in +`euclidDivScript.sml`. + +Theorem 7 (Second Phase Soundness) from section 4 is proven in file +`checkerScript.sml` as the combination of `numZeros_sound`, +`validBounds_is_valid`, and `validateZerosLeqErr_sound`. + +Theorem 8 was ported from Harrison's HOL-Light proofs in file `drangScript.sml` +and is called `BOUND_THEOREM_INEXACT`. + +Theorem 9 (Dandelion soundness) is called `checker_soundness` in file +`checkerScript.sml`. + +The extracted binary is created in the directory `binary`. +File `translateScript.sml` sets up the CakeML translation of the definitions of +Dandelion, file `certParserScript.sml` defines our (unverified) parser and +lexer, file `sturmMainCakeScript.sml` proves the CakeML specification for the +binary, and file `sturmMainCakeCompileScript.sml` compiles the binary for the +second phase by running the CakeML compiler in-logic on the translated +definitions. \ No newline at end of file diff --git a/floatingPoint/tools/dandelion/realPolyProofsScript.sml b/floatingPoint/tools/dandelion/realPolyProofsScript.sml new file mode 100644 index 0000000000..b993aff197 --- /dev/null +++ b/floatingPoint/tools/dandelion/realPolyProofsScript.sml @@ -0,0 +1,1946 @@ +(** + Some simple properties of polynomials on reals +**) +open realTheory realLib RealArith renameTheory polyTheory; +open realPolyTheory; +open preambleDandelion; + +val _ = new_theory "realPolyProofs"; + +(** + Evaluation properties +**) +Triviality evalPoly_neg = SIMP_RULE std_ss [polyEvalsTo_def] polyEvalsTo_Neg +Triviality evalPoly_add = SIMP_RULE std_ss [polyEvalsTo_def] polyEvalsTo_Add +Triviality evalPoly_sub = SIMP_RULE std_ss [polyEvalsTo_def] polyEvalsTo_Sub +Triviality evalPoly_mulcst = SIMP_RULE std_ss [polyEvalsTo_def] polyEvalsTo_MulCst +Triviality evalPoly_mul = SIMP_RULE std_ss [polyEvalsTo_def] polyEvalsTo_Mul +Triviality evalPoly_pow = SIMP_RULE std_ss [polyEvalsTo_def] polyEvalsTo_Pow + +Theorem eval_simps = LIST_CONJ [evalPoly_neg, evalPoly_add, evalPoly_sub, + evalPoly_mulcst, evalPoly_mul, evalPoly_pow] + +val field_prove = gs[eval_simps] >> real_tac; + +(** + Identities +**) +Theorem mul_cst1: + (1 *c p) = reduce p +Proof + Induct_on ‘p’ >> gs[poly_mul_cst_def, reduce_def, poly_mul_cst_aux_def] + >> rpt strip_tac >> cond_cases_tac >> gs[] +QED + +Theorem mul_cst_1: + reduce p = p ⇒ + 1 *c p = p +Proof + Induct_on ‘p’ + >- gs[poly_mul_cst_def, reduce_def, poly_mul_cst_aux_def] + >> rpt strip_tac + >> gs[poly_mul_cst_def] + >> ‘reduce p = p’ + by (gs[reduce_def] >> pop_assum mp_tac >> rpt (COND_CASES_TAC >> gs[])) + >> gs[poly_mul_cst_aux_def, reduce_def] +QED + +Theorem evalPoly_mul_cst1: + ∀ p x. + evalPoly (1 *c p) x = evalPoly p x +Proof + gs[evalPoly_mulcst] +QED + +Theorem poly_mul_cst_0: + 0 *c p = [] +Proof + Induct_on ‘p’ >- EVAL_TAC + >> rpt strip_tac >> gs[poly_mul_cst_def, Once poly_mul_cst_aux_def, reduce_def] +QED + +Theorem mul_0_right[compute]: + (p *p []) = [] +Proof + Induct_on ‘p’ >> gs[poly_mul_def] + >> rpt strip_tac >> gs[poly_mul_cst_def, poly_mul_cst_aux_def, reduce_def] + >> cond_cases_tac >> gs[poly_add_def, poly_add_aux_def, reduce_def] +QED + +Theorem mul_0_left[compute]: + ([] *p p) = [] +Proof + Induct_on ‘p’ + >- gs[mul_0_right] + >> strip_tac + >> gs[poly_mul_def] +QED + +Theorem poly_cst_mult_nul: + ∀a. (a *c []) = [] +Proof + strip_tac >> gs[poly_mul_cst_def, poly_mul_cst_aux_def, reduce_def] +QED + +Theorem poly_add_rid: + ∀p. [] +p p = reduce p +Proof + Induct_on ‘p’ + >- gs[poly_add_def, poly_add_aux_def, reduce_def] + >> strip_tac + >> gs[poly_add_def, poly_add_aux_def] +QED + +(** + Algebraic properties +**) +Theorem evalPoly_add_comm: + ∀ p1 p2 x. + evalPoly (p1 +p p2) x = evalPoly (p2 +p p1) x +Proof + field_prove +QED + +Theorem evalPoly_add_assoc: + ∀ p1 p2 p3 x. + evalPoly (p1 +p (p2 +p p3)) x = evalPoly ((p1 +p p2) +p p3) x +Proof + field_prove +QED + +Theorem evalPoly_mul_comm: + ∀ p1 p2 x. + evalPoly (p1 *p p2) x = evalPoly (p2 *p p1) x +Proof + gs[evalPoly_mul] >> real_tac +QED + +Theorem evalPoly_mul_assoc: + ∀ p1 p2 p3 x. + evalPoly (p1 *p (p2 *p p3)) x = evalPoly ((p1 *p p2) *p p3) x +Proof + gs[evalPoly_mul] >> real_tac +QED + +Theorem evalPoly_mul_distrib_l: + ∀ p1 p2 p3 x. + evalPoly (p1 *p (p2 +p p3)) x = evalPoly ((p1 *p p2) +p (p1 *p p3)) x +Proof + gs[evalPoly_mul, evalPoly_add] >> real_tac +QED + +Theorem poly_mul_cst_reduce: + c *c reduce p = c *c p +Proof + Induct_on ‘p’ >> gs[poly_mul_cst_def] + >- gs[reduce_def, poly_mul_cst_aux_def] + >> strip_tac >> gs[reduce_def, poly_mul_cst_aux_def] + >> Cases_on ‘reduce p’ >> gs[] + >- ( + Cases_on ‘h = 0’ >> gs[] + >> qpat_x_assum `reduce (poly_mul_cst_aux _ _) = _` $ rewrite_tac o single o GSYM + >> gs[poly_mul_cst_aux_def, reduce_def]) + >> qpat_x_assum `reduce (poly_mul_cst_aux _ _) = _` $ rewrite_tac o single o GSYM + >> gs[poly_mul_cst_aux_def, reduce_def] +QED + +(** Properties of deg function **) + +Theorem deg_oEL: + ∀ p n. + deg p < n ⇒ + oEL n p = NONE ∨ oEL n p = SOME 0 +Proof + Induct_on ‘p’ >> gs[deg_def, reduce_def, oEL_def] + >> rpt strip_tac + >> Cases_on ‘reduce p = []’ >> gs[] + >- ( + Cases_on ‘n’ >> gs[] + >> rename1 ‘oEL n p = NONE’ + >> Cases_on ‘n’ >> gs[] + >> Cases_on ‘oEL 0 p’ >> gs[] + >> ‘∃ y ys. p = y::ys’ by (Cases_on ‘p’ >> gs[oEL_def]) + >> VAR_EQ_TAC >> gs[oEL_def, reduce_def] + >> Cases_on ‘reduce ys = []’ >> gs[] + >> Cases_on ‘x = 0’ >> gs[]) + >> Cases_on ‘n’ >> gs[] + >> rename1 ‘oEL n p = NONE’ + >> Cases_on ‘n’ >> gs[] + >> Cases_on ‘p’ >> gs[reduce_def, oEL_def] + >> Cases_on ‘reduce t = []’ >> gs[] + >> Cases_on ‘h = 0’ >> gs[] +QED + +Theorem coeff_eq_0: + ∀ p n. + deg p < n ⇒ + coeff p n = 0 +Proof + rpt strip_tac >> drule deg_oEL + >> gs[coeff_def] >> strip_tac >> gs[] +QED + +Theorem le_degree: + ∀ p n. + coeff p n ≠ 0 ⇒ n ≤ deg p +Proof + CCONTR_TAC >> gs[] + >> ‘deg p < n’ by gs[] + >> imp_res_tac coeff_eq_0 +QED + +(** Properties of monom function **) + +Theorem monom_n: + ∀ n. coeff (monom n [p]) n = p +Proof + Induct_on ‘n’ >> gs[coeff_def, monom_def, monom_def, oEL_def] +QED + +Theorem monom_SUC: + monom (SUC n) p = 0 :: monom n p +Proof + gs[monom_def, monom_def] +QED + +Theorem monom_0_mul: + ∀ n p. monom n [0] *p p = [] +Proof + Induct_on ‘n’ + >- gs[monom_def, monom_def, poly_mul_def, poly_mul_cst_0, poly_add_def, + reduce_def, poly_add_aux_def] + >> gs[Once monom_SUC] >> rpt strip_tac + >> gs[Once poly_mul_def, poly_mul_cst_0] + >> COND_CASES_TAC >> gs[poly_add_def, reduce_def, poly_add_aux_def] +QED + +(** Properties of coeff function **) + +Theorem coeff_monom_0_mul: + ∀ n m p. coeff (monom n [0] *p p) m = 0 +Proof + gs[monom_0_mul, coeff_def, oEL_def] +QED + +Theorem coeff_empty: + coeff [] n = 0 +Proof + gs[coeff_def, oEL_def] +QED + +Theorem deg_le: + ∀ p n. + (∀ i. n < i ⇒ coeff p i = 0) ⇒ + deg p ≤ n +Proof + Induct_on ‘n’ + >- ( + Induct_on ‘p’ >> gs[deg_def, reduce_def] + >> rpt strip_tac >> cond_cases_tac + >- (cond_cases_tac >> gs[]) + >> gs[] + >> ‘∀ i. 0 < i ⇒ coeff p i = 0’ + by ( + rpt strip_tac + >> res_tac + >> gs[coeff_def] + >> first_x_assum $ qspec_then ‘SUC i’ mp_tac >> gs[oEL_def]) + >> res_tac + >> Cases_on ‘p’ >> gs[reduce_def] + >> last_x_assum $ qspec_then ‘1’ mp_tac + >> gs[coeff_def, oEL_def] >> rpt strip_tac + >> ‘reduce t = []’ by (Cases_on ‘reduce t’ >> gs[]) + >> gs[]) + >> rpt strip_tac + >> Cases_on ‘p’ >> gs[deg_def, reduce_def] + >> ‘∀ i. n < i ⇒ coeff t i = 0’ + by ( + rpt strip_tac + >> ‘SUC n < SUC i’ by gs[] + >> res_tac >> fs[coeff_def, oEL_def]) + >> res_tac + >> rpt (cond_cases_tac >> fs[]) +QED + +Theorem eq_zero_or_degree_less: + ∀ p n. + deg p ≤ n ∧ coeff p n = 0 ⇒ + zerop p ∨ deg p < n +Proof + rpt strip_tac >> Cases_on ‘n’ + >- ( + ‘coeff p (deg p) = 0’ by gs[] + >> ‘deg p = 0’ by gs[] + >> Cases_on ‘p’ >> gs[deg_def, coeff_def, oEL_def, zerop_def, reduce_def] + >> Cases_on ‘reduce t’ >> gs[]) + >> rename1 ‘deg p ≤ SUC m’ + >> ‘∀ i. SUC m < i ⇒ coeff p i = 0’ + by (rpt strip_tac + >> ‘deg p < i’ by gs[] + >> imp_res_tac coeff_eq_0) + >> ‘∀ i. SUC m ≤ i ⇒ coeff p i = 0’ + by (gs[LESS_OR_EQ] >> rpt strip_tac >> gs[]) + >> ‘∀ i. m < i ⇒ coeff p i = 0’ by gs[] + >> imp_res_tac deg_le + >> gs[] +QED + +Theorem coeff_0_degree_minus_1: + coeff p n = 0 ∧ deg p ≤ n ⇒ deg p ≤ n - 1 +Proof + rpt strip_tac + >> ‘zerop p ∨ deg p < n’ by (drule_then drule eq_zero_or_degree_less >> gs[]) + >- gs[zerop_def, deg_def] + >> gs[] +QED + +Theorem coeff_cst_mul: + ∀c p n. coeff (c *c p) n = c * coeff p n +Proof + gen_tac >> + ‘c = 0 ∨ c ≠ 0’ by gs[] + >- ( pop_assum $ rewrite_tac o single >> gs[poly_mul_cst_0, coeff_empty] ) + >> Induct_on ‘n’ + >- ( gs[coeff_def] >> gs[poly_mul_cst_def] + >> Induct_on ‘p’ + >- gs[oEL_def, poly_mul_cst_aux_def, reduce_def] + >> strip_tac >> gs[oEL_def] >> gs[poly_mul_cst_aux_def] + >> gs[reduce_def] >> cond_cases_tac + >- ( cond_cases_tac >> gs[oEL_def] ) + >> gs[oEL_def] + >> gs[oEL_def] + ) + >> strip_tac + >> gs[coeff_def] >> Induct_on ‘p’ + >- gs[poly_cst_mult_nul, oEL_def] + >> strip_tac >> gs[poly_mul_cst_def] >> gs[poly_mul_cst_aux_def] + >> gs[reduce_def] >> cond_cases_tac + >- ( gs[oEL_def] >> cond_cases_tac + >- ( gs[oEL_def] + >> qpat_x_assum ‘ ∀p'. _ ’ $ qspec_then ‘p’ assume_tac + >> gs[oEL_def] + ) + >> gs[oEL_def] + >> qpat_x_assum ‘∀p'. _’ $ qspec_then ‘p’ assume_tac + >> gs[oEL_def] + ) + >> gs[oEL_def] +QED + +Theorem coeff_add: + ∀p1 p2 n. coeff (p1 +p p2) n = coeff p1 n + coeff p2 n +Proof + Induct_on ‘n’ + >- ( rpt strip_tac >> gs[coeff_def, oEL_def] + >> Cases_on ‘p1’ + >- ( gs[oEL_def, poly_add_rid] + >> Induct_on ‘p2’ + >- gs[reduce_def, oEL_def] + >> strip_tac >> gs[reduce_def] + >> cond_cases_tac + >- ( gs[oEL_def] >> cond_cases_tac >> gs[oEL_def] ) + >> gs[oEL_def] + ) + >> gs[oEL_def] >> Induct_on ‘p2’ + >- ( gs[poly_add_def, poly_add_aux_def] >> gs[reduce_def, oEL_def] + >> cond_cases_tac + >- ( cond_cases_tac >> gs[oEL_def] ) + >> gs[oEL_def] + ) + >> strip_tac >> gs[oEL_def] + >> gs[poly_add_def, poly_add_aux_def] + >> gs[reduce_def] >> cond_cases_tac + >- ( cond_cases_tac >> gs[oEL_def] ) + >> gs[oEL_def] + ) + >> rpt strip_tac >> gs[coeff_def] + >> Cases_on ‘p1’ + >- ( gs[oEL_def, poly_add_rid] + >> Induct_on ‘p2’ + >- gs[reduce_def, oEL_def] + >> strip_tac >> gs[reduce_def] + >> cond_cases_tac + >- ( gs[oEL_def] >> cond_cases_tac >> gs[oEL_def] + >> last_x_assum $ qspecl_then [‘[]’, ‘p2’] assume_tac + >> gs[poly_add_rid, oEL_def] + ) + >> gs[oEL_def] + >> last_x_assum $ qspecl_then [‘[]’, ‘p2’] assume_tac + >> gs[poly_add_rid, oEL_def] + ) + >> gs[oEL_def] >> Induct_on ‘p2’ + >- ( gs[poly_add_lid] + >> gs[oEL_def] >> gs[reduce_def] + >> cond_cases_tac + >- ( cond_cases_tac >> gs[oEL_def] + >> last_x_assum $ qspecl_then [‘[]’, ‘t’] assume_tac + >> gs[poly_add_rid, oEL_def] + ) + >> gs[oEL_def] + >> last_x_assum $ qspecl_then [‘[]’, ‘t’] assume_tac + >> gs[poly_add_rid, oEL_def] + ) + >> strip_tac >> gs[oEL_def] + >> gs[poly_add_def, poly_add_aux_def] + >> gs[reduce_def] >> cond_cases_tac + >- ( cond_cases_tac >> gs[oEL_def] + >> last_x_assum $ qspecl_then [‘t’, ‘p2’] assume_tac + >> gs[oEL_def] + ) + >> gs[oEL_def] +QED + +Theorem length_gt_0: + ∀ t. t ≠ [] ⇒ 0 < LENGTH t +Proof + Induct_on ‘t’ + >- gs[] + >> rpt strip_tac + >> gs[LENGTH] +QED + +Theorem deg_suc: + ∀p. 0 < deg p ⇒ + deg (h::p) = SUC (deg p) +Proof + rpt strip_tac + >> gs[deg_def, reduce_def] + >> cond_cases_tac >> gs[LENGTH] +QED + +Theorem deg_1: + ∀p. deg p = 0 ⇒ 0 < deg (h::p) ⇒ deg (h::p) = 1 +Proof + gs[deg_def] + >> Induct_on ‘p’ + >- ( gs[reduce_def, LENGTH] >> cond_cases_tac >> gs[]) + >> rpt strip_tac + >> gs[reduce_def] + >> Cases_on ‘reduce p = []’ + >- ( gs[] >> Cases_on ‘h' = 0’ >> gs[] ) + >> gs[] >> last_x_assum mp_tac >> gs[] + >> ‘∀m:num. 0 < m ⇒ 1 ≤ m’ by gs[] + >> first_assum irule + >> gs[length_gt_0] +QED + +Theorem deg_length: + ∀p. 0 < deg p ⇒ + LENGTH (reduce p) > 1 +Proof + Induct_on ‘p’ + >- gs[deg_def, reduce_def, LENGTH] + >> gs[deg_def] +QED + +Theorem deg_p_ge_0: + ∀p. p ≠ [] ⇒ 0 ≤ deg p +Proof + Induct_on ‘p’ + >- gs[] + >> rpt strip_tac + >> gs[deg_def] +QED + +Theorem deg_eq_arg: + ∀ x y p. deg (x::p) = 0 ∧ deg p = 0 ⇒ + deg (y::p) = 0 +Proof + Induct_on ‘p’ + >- (gs[deg_def, reduce_def] >> rpt strip_tac >> COND_CASES_TAC >> gs[]) + >> rpt strip_tac + >> gs[deg_def, reduce_def] + >> Cases_on ‘reduce p = []’ >> gs[] + >> Cases_on ‘h = 0’ >> gs[] + >> COND_CASES_TAC >> gs[] +QED + +Theorem coeff_single: + coeff [x] (deg [x]) = x +Proof + gs[deg_def, coeff_def, reduce_def] + >> Cases_on ‘x = 0’ >> gs[oEL_def] +QED + +Theorem deg_single: + deg [x] = 0 +Proof + gs[deg_def, reduce_def] + >> Cases_on ‘x = 0’ >> gs[] +QED + +Theorem coeff_cons: + 0 < deg (x::p) ⇒ + coeff (x::p) (deg (x::p)) = coeff p (deg p) +Proof + rpt strip_tac >> gs[coeff_def, oEL_def] + >> ‘deg (x::p) = SUC (deg p)’ + by (gs[deg_def, reduce_def] >> every_case_tac >> gs[]) + >> gs[] +QED + +Theorem deg_pos: + 0 < deg (x::p) ⇒ + deg (x::p) = 1 + deg p +Proof + gs[deg_def, reduce_def] + >> rpt (cond_cases_tac >> gs[]) +QED + +Theorem reduce_mult: + reduce p *p q = p *p q +Proof + Induct_on ‘p’ >> gs[reduce_def] + >> rpt strip_tac + >> Cases_on ‘reduce p’ >> gs[] + >- ( + Cases_on ‘h = 0’ >> gs[] >> rpt VAR_EQ_TAC + >- ( + simp[SimpR“$=”, poly_mul_def, poly_mul_cst_0, poly_add_rid] + >> Cases_on ‘p’ >> gs[mul_0_left ,reduce_def]) + >> gs[poly_mul_def, poly_add_lid] + >> cond_cases_tac >> gs[poly_add_lid]) + >> gs[poly_mul_def] + >> ‘p ≠ []’ by (Cases_on ‘p’ >> gs[reduce_def]) + >> gs[] +QED + +Theorem mult_zerop_l: + zerop p ⇒ + p *p q = [] +Proof + rpt strip_tac >> gs[zerop_def] >> once_rewrite_tac [GSYM reduce_mult] >> gs[mul_0_left] +QED + +Theorem coeff_mult_degree_sum: + ∀ p q. coeff (p *p q) (deg p + deg q) = coeff p (deg p) * coeff q (deg q) +Proof + Induct_on ‘p’ >> gs[poly_mul_def] + >- gs[coeff_empty] + >> Cases_on ‘p’ >> gs[] + >> rpt strip_tac + >- gs[poly_add_lid, poly_mul_cst_reduced, mul_0_left, coeff_empty, + coeff_single, deg_single, coeff_cst_mul] + >> gs[coeff_add, coeff_cst_mul] + >> rename1 ‘x1 * coeff q (deg q + deg (x1::x2::p))’ + >> ‘deg q < deg q + deg (x1::x2::p) ∨ + (deg q = deg q + deg (x1::x2::p) ∧ deg (x1::x2::p) = 0)’ + by (gs[deg_def, reduce_def] + >> Cases_on ‘reduce p’ >> gs[] + >> Cases_on ‘x2 = 0’ >> gs[] + >> Cases_on ‘x1 = 0’ >> gs[]) + >- ( + imp_res_tac coeff_eq_0 >> gs[] + >> ‘0 < deg q + deg (x1::x2::p)’ by gs[] + >> ‘∃ n. deg q + deg (x1::x2::p) = SUC n’ + by (Cases_on ‘deg q + deg (x1::x2::p)’ >> gs[]) + >> gs[SimpL “$=”, coeff_def, oEL_def] + >> first_x_assum $ qspec_then ‘q’ mp_tac + >> gs[coeff_cons] + >> disch_then $ rewrite_tac o single o GSYM + >> gs[deg_pos] >> ‘n = deg q + deg (x2::p)’ by gs[] + >> VAR_EQ_TAC >> gs[]) + >> fs[coeff_def, oEL_def] + >> ‘deg (x2::p) = 0’ by (gs[deg_def, reduce_def] >> every_case_tac >> gs[]) + >> ‘x2 = 0’ by (gs[deg_def, reduce_def] + >> Cases_on ‘reduce p’ >> gs[] + >> Cases_on ‘x2 = 0’ >> gs[]) + >> ‘zerop (x2::p)’ + by ( + ‘coeff (x2::p) 0 = 0’ by (gs[coeff_def, oEL_def]) + >> imp_res_tac eq_zero_or_degree_less >> gs[]) + >> gs[mult_zerop_l, oEL_def] + >> cond_cases_tac >> gs[] +QED + +(** + Properties of deg +**) + +Theorem deg_monom_eq: + a ≠ 0 ⇒ deg (monom n [a]) = n +Proof + Induct_on ‘n’ >> gs[monom_def, monom_def, deg_def, reduce_def] + >> rpt strip_tac >> res_tac + >> COND_CASES_TAC >- gs[reduce_def, monom_def] + >> Cases_on ‘reduce (monom n [a])’ >> gs[] +QED + +Theorem reduce_p_poly_mul_holds: + ∀p. reduce p = [] ⇒ + reduce (poly_mul_cst_aux c p) = [] +Proof + Induct_on ‘p’ + >- gs[poly_mul_cst_aux_def, reduce_def] + >> rpt strip_tac + >> gs[poly_mul_cst_aux_def] + >> gs[reduce_def] + >> pop_assum mp_tac + >> cond_cases_tac + >- ( res_tac >> gs[] >> cond_cases_tac >> gs[] ) + >> gs[] +QED + +Theorem reduce_poly_mul_cst: + ∀ c p. reduce p = [] ⇒ + c *c p = [] +Proof + gs[poly_mul_cst_def, reduce_p_poly_mul_holds] +QED + +Theorem reduce_p_poly_mul_holds_not: + ∀p. c ≠ 0 ⇒ reduce p ≠ [] ⇒ + reduce (poly_mul_cst_aux c p) ≠ [] +Proof + Induct_on ‘p’ + >- gs[reduce_def] + >> rpt strip_tac + >> pop_assum mp_tac >> gs[] + >> gs[poly_mul_cst_aux_def] + >> gs[reduce_def] + >> pop_assum mp_tac + >> cond_cases_tac + >- ( gs[reduce_p_poly_mul_holds] >> cond_cases_tac >> gs[] ) + >> gs[] +QED + +Theorem deg_leq_mul_cst: + deg (c *c p) ≤ deg p +Proof + ‘c = 0 ∨ c ≠ 0’ by gs[] + >- ( pop_assum $ rewrite_tac o single >> gs[poly_mul_cst_0] + >> ‘deg [] = 0’ by + ( gs[deg_def, reduce_def] ) + >> pop_assum $ rewrite_tac o single + >> gs[deg_def] + ) + >> gs[deg_def] + >> gs[poly_mul_cst_def, poly_mul_cst_aux_def, reduce_idempotent] + >> Induct_on ‘p’ + >- gs[poly_mul_cst_aux_def, reduce_def] + >> gs[poly_mul_cst_aux_def] >> strip_tac + >> gs[reduce_def] + >> Cases_on ‘reduce p = []’ + >- ( + gs[reduce_p_poly_mul_holds] + >> cond_cases_tac >> gs[] + ) + >> gs[reduce_p_poly_mul_holds_not] + >> ‘∀m n:num. m ≤ n ⇒ SUC m ≤ n+1’ by gs[] + >> first_x_assum irule + >> ‘1 ≤ LENGTH (reduce p) ⇒ + LENGTH (reduce p) = 1 + (LENGTH (reduce p) - 1) ’ by gs[] + >> ‘ 1 ≤ LENGTH (reduce p)’ by + ( qpat_x_assum ‘reduce p ≠ []’ mp_tac + >> POP_ASSUM_LIST kall_tac + >> strip_tac + >> Induct_on ‘p’ + >- gs[reduce_def] + >> rpt strip_tac + >> gs[reduce_def] + >> cond_cases_tac + >- ( + gs[] >> cond_cases_tac + >- gs[] + >> gs[LENGTH] + ) + >> gs[LENGTH] + ) + >> res_tac + >> gs[] +QED + +Theorem deg_of_const_mul: + ∀ c p. c ≠ 0 ⇒ deg (c *c p) = deg p +Proof + rpt strip_tac + >> gs[deg_def] >> gs[poly_mul_cst_reduced] + >> gs[poly_mul_cst_def, poly_mul_cst_aux_def] + >> Induct_on ‘p’ + >- gs[poly_mul_cst_aux_def, reduce_def, LENGTH] + >> gs[poly_mul_cst_aux_def] >> gs[reduce_def] + >> Cases_on ‘reduce p = []’ + >- ( gs[reduce_p_poly_mul_holds] >> strip_tac >> cond_cases_tac >> gs[LENGTH] ) + >> strip_tac + >> gs[reduce_p_poly_mul_holds_not] + >> ‘∀m n:num. 0 < m ∧ 0 < n ⇒ m - 1 = n - 1 ⇒ m = n’ by gs[] + >> first_assum irule >> rpt conj_tac + >- gs[length_gt_0,reduce_p_poly_mul_holds_not] + >> gs[length_gt_0] + >> gs[] +QED + +Theorem reduce_h_not_null: + ∀h. reduce [h] ≠ [] ⇒ h ≠ 0 +Proof + rpt strip_tac + >> last_assum mp_tac + >> gs[reduce_def] +QED + +Theorem reduce_0_scal: + ∀h:real. reduce (0 :: [h]) ≠ [] ⇒ reduce [h] ≠ [] +Proof + rpt strip_tac >> gs[reduce_def] +QED + +Theorem deg_0_scal: + ∀h. h ≠ 0 ⇒ deg (0 :: [h]) = 1 +Proof + rpt strip_tac + >> gs[deg_def, reduce_def] +QED + +Theorem reduce_add_zero_r: + ∀ p1 p2. reduce p2 = [] ⇒ + reduce (poly_add_aux p1 p2) = reduce p1 +Proof + Induct_on ‘p1’ >> gs[poly_add_aux_def, reduce_def] + >> rpt strip_tac >> res_tac + >> Cases_on ‘p2’ >> gs[reduce_def] + >> Cases_on ‘reduce t’ >> gs[] + >> Cases_on ‘h' = 0’ >> gs[] +QED + +Theorem reduce_add_zero_l: + ∀p1 p2. + reduce p1 = [] ⇒ + reduce (poly_add_aux p1 p2) = reduce p2 +Proof + Induct_on ‘p1’ >> rpt strip_tac + >- gs[reduce_def, poly_add_aux_def] + >> gs[poly_add_aux_def] + >> Cases_on ‘p2’ + >- gs[reduce_def] + >> gs[] >> gs[reduce_def] + >> Cases_on ‘reduce t = []’ >> gs[] + >- ( + Cases_on ‘reduce p1 = []’ >> gs[] + >> Cases_on ‘h=0’ >> gs[] + >> Cases_on ‘reduce (poly_add_aux p1 t) = []’ >> gs[] + >> cond_cases_tac + >> gs[reduce_add_zero_r]) + >> Cases_on ‘reduce p1 = []’ >> gs[reduce_add_zero_r] + >> Cases_on ‘h=0’ >> gs[] +QED + + +Theorem reduce_add_zero_r: + ∀p1 p2. + reduce p2 = [] ⇒ + reduce (poly_add_aux p1 p2) = reduce p1 +Proof + Induct_on ‘p1’ + >- gs[poly_add_aux_def, reduce_def] + >> rpt strip_tac + >> gs[poly_add_aux_def] + >> Cases_on ‘p2’ + >- gs[] + >> gs[] >> gs[reduce_def] + >> Cases_on ‘reduce p1 = []’ + >- ( gs[reduce_add_zero_l] + >> Cases_on ‘reduce t = []’ + >- ( gs[] >> Cases_on ‘h=0’ + >- gs[] + >> gs[] >> Cases_on ‘h' = 0’ >> gs[] + ) + >> gs[] + ) + >> gs[] + >> Cases_on ‘reduce t = []’ + >- ( gs[] >> Cases_on ‘h' = 0’ >> gs[] ) + >> gs[] +QED + +Theorem mult_zerop_r: + ∀p q. zerop q ⇒ p *p q = [] +Proof + Induct_on ‘p’ + >- gs[mul_0_left ] + >> rpt strip_tac + >> gs[zerop_def, poly_mul_def] + >> Cases_on ‘p = []’ + >> gs[poly_add_lid, poly_mul_cst_reduced] + >> ‘ h *c q = h *c reduce q’ by gs[poly_mul_cst_reduce] + >> gs[poly_cst_mult_nul] +QED + +Theorem reduce_poly_add_not_null: + ∀ p q. reduce p ≠ [] ⇒ reduce q ≠ [] ⇒ + deg p < deg q ⇒ + reduce (poly_add_aux p q) ≠ [] +Proof + Induct_on ‘p’ + >- gs[reduce_def] + >> rpt strip_tac + >> gs[poly_add_aux_def] + >> Cases_on ‘q’ + >- gs[] + >> gs[] >> gs[reduce_def, deg_def] + >> Cases_on ‘reduce t = []’ + >- ( gs[reduce_add_zero_r] + >> Cases_on ‘h' = 0’ + >- gs[] + >> gs[] + ) + >> gs[] + >> Cases_on ‘reduce p = []’ + >- gs[reduce_add_zero_l] + >> gs[] + >> last_x_assum $ qspec_then ‘t’ assume_tac + >> gs[] + >> Cases_on ‘reduce (poly_add_aux p t) = []’ + >- ( gs[] + >> ‘LENGTH (reduce t) = 1’ by + ( ‘0 < LENGTH(reduce t)’ by gs[length_gt_0] + >> gs[] + ) + >> last_x_assum mp_tac + >> gs[] + >> ‘∀m:num. 1 ≤ m ⇒ ~ ( m < 1)’ by gs[] + >> pop_assum irule + >> ‘0 < LENGTH(reduce p)’ by gs[length_gt_0] + >> gs[] + ) + >> gs[] +QED + +Theorem deg_cast : + ∀ p1 p2. deg p1 < deg p2 ⇒ + deg (reduce (poly_add_aux p1 p2)) = deg p2 +Proof + Induct_on ‘p1’ + >- ( gs[poly_add_aux_def] + >> rpt strip_tac + >> gs[deg_def, reduce_idempotent] + ) + >> rpt strip_tac + >> gs[poly_add_aux_def] + >> Cases_on ‘p2’ + >- ( gs[] >> gs[deg_def, reduce_def] ) + >> gs[] >> gs[deg_def, reduce_def] + >> Cases_on ‘reduce t = []’ + >- ( gs[reduce_add_zero_r] >> cond_cases_tac + >- ( gs[] >> Cases_on ‘h'=0’ + >- ( gs[] >> cond_cases_tac >> gs[reduce_def, LENGTH] ) + >> gs[] >> cond_cases_tac >> gs[reduce_def, LENGTH] + ) + >> gs[reduce_def, reduce_idempotent] + >> Cases_on ‘h'=0’ + >- gs[] + >> gs[] + ) + >> gs[] + >> Cases_on ‘reduce p1 = []’ + >- ( gs[reduce_add_zero_l] + >> gs[reduce_def, reduce_idempotent] + ) + >> last_x_assum $ qspec_then ‘t’ assume_tac + >> gs[] + >> ‘reduce (poly_add_aux p1 t) ≠ []’ by + ( irule reduce_poly_add_not_null >> gs[] + >> ‘deg p1 = LENGTH (reduce p1) - 1’ by gs[deg_def] + >> pop_assum $ rewrite_tac o single + >> ‘deg t = LENGTH (reduce t) - 1’ by gs[deg_def] + >> pop_assum $ rewrite_tac o single + >> ‘∀ m n:num. 0 < m ⇒ 0 < n ⇒ m < n ⇒ m - 1 < n-1’ by gs[] + >> first_assum irule >> gs[length_gt_0] + ) + >> gs[reduce_def, reduce_idempotent] + >> ‘∀m n:num. 0 < m ∧ 0 < n ⇒ m-1 = n-1 ⇒ m = n’ by gs[] + >> pop_assum irule >> gs[] >> conj_tac + >- ( irule length_gt_0 >> gs[] ) + >> ‘1 < LENGTH (reduce t)’ by + ( ‘∀m n: num. m -1 < n - 1 ⇒ m < n ’ by gs[] + >> pop_assum irule + >> ‘1-1 = 0 ’ by gs[] + >> gs[] + >> irule LESS_LESS_EQ_TRANS + >> qexists_tac ‘LENGTH (reduce p1)’ + >> gs[length_gt_0] + ) + >> first_assum irule >> gs[] +QED + +Theorem length_reduce_eq: + ∀ h p. reduce p ≠ [] ⇒ h ≠ 0 ⇒ LENGTH (h *c reduce p) = LENGTH (reduce p) +Proof + rpt strip_tac + >> ‘∀m n:num. 0 < m ⇒ 0 < n ⇒ m - 1 = n -1 ⇒ m = n’ by gs[] + >> first_assum irule + >> ‘ LENGTH (reduce (h *c p)) - 1 = deg (h *c p) ’ by gs[deg_def] + >> ‘LENGTH (reduce p) -1 = deg p ’ by gs[deg_def] + >> gs[poly_mul_cst_reduced, poly_mul_cst_reduce ] + >> gs[deg_of_const_mul] + >> gs[length_gt_0] + >> irule length_gt_0 + >> gs[poly_mul_cst_def] + >> pop_assum kall_tac + >> pop_assum kall_tac + >> gs[reduce_p_poly_mul_holds_not] +QED + +Theorem reduce_mul_zero_r: + ∀ p1 p2. + reduce p2 = [] ⇒ + p1 *p p2 = [] +Proof + Induct_on ‘p1’ >> gs[poly_mul_def] + >> rpt strip_tac + >> gs[reduce_poly_mul_cst, poly_add_rid] + >> cond_cases_tac >> gs[reduce_def] +QED + +Theorem reduce_mul_zero_l: + ∀ p1 p2. + reduce p1 = [] ⇒ + p1 *p p2 = [] +Proof + Induct_on ‘p1’ >> gs[poly_mul_def] + >> rpt strip_tac + >> ‘h = 0’ by (gs[reduce_def] >> every_case_tac >> gs[]) + >> gs[poly_mul_cst_0, poly_add_rid] + >> ‘reduce p1 = []’ by (gs[reduce_def] >> every_case_tac >> gs[]) + >> cond_cases_tac >> gs[reduce_def] +QED + +Theorem reduce_poly_mul_cst_not_null: + ∀ p1 c. + reduce p1 ≠ [] ∧ + c ≠ 0 ⇒ + c *c p1 ≠ [] +Proof + Induct_on ‘p1’ >> gs[reduce_def] + >> rpt strip_tac >> Cases_on ‘reduce p1’ + >> gs[poly_mul_cst_def, poly_mul_cst_aux_def, reduce_def] + >> imp_res_tac reduce_p_poly_mul_holds >> gs[] + >> Cases_on ‘h = 0’ >> gs[] +QED + +Theorem deg_reduce: + deg (reduce p) = deg p +Proof + gs[deg_def, reduce_idempotent] +QED + +Theorem deg_add_poly: + ∀ p1 p2. deg (p1 +p p2) ≤ MAX (deg p1) (deg p2) +Proof + Induct_on ‘p1’ + >- (gs[poly_add_rid, deg_reduce]) + >> rpt strip_tac + >> gs[poly_add_def, poly_add_aux_def, deg_reduce] + >> Cases_on ‘p2’ >> gs[deg_def, reduce_def] + >> Cases_on ‘reduce (poly_add_aux p1 t) = []’ >> gs[] + >- (Cases_on ‘h + h' = 0’ >> gs[]) + >> Cases_on ‘reduce p1 = []’ >> gs[] + >- (Cases_on ‘h = 0’ >> gs[reduce_add_zero_l]) + >> first_x_assum $ qspec_then ‘t’ assume_tac + >> gs[] + >- ( + DISJ1_TAC + >> ‘LENGTH (reduce (poly_add_aux p1 t)) ≤ LENGTH (reduce p1)’ suffices_by gs[] + >> ‘0 < LENGTH (reduce p1)’ by (Cases_on ‘reduce p1’ >> gs[]) + >> gs[]) + >> Cases_on ‘reduce t = []’ >> gs[] + >- ( + DISJ1_TAC + >> ‘LENGTH (reduce (poly_add_aux p1 t)) ≤ LENGTH (reduce p1)’ suffices_by gs[] + >> ‘1 ≤ LENGTH (reduce p1)’ by (Cases_on ‘reduce p1’ >> gs[]) + >> gs[]) + >> DISJ2_TAC + >> ‘LENGTH (reduce (poly_add_aux p1 t)) ≤ LENGTH (reduce t)’ suffices_by gs[] + >> ‘0 < LENGTH (reduce t)’ by (Cases_on ‘reduce t’ >> gs[]) + >> ‘1 + (LENGTH (reduce t) - 1) = LENGTH (reduce t)’ by gs[] + >> gs[] +QED + +Theorem deg_poly_neg: + deg (--p p) = deg p +Proof + gs[poly_neg_def, deg_of_const_mul] +QED + +Theorem deg_sub_poly: + deg (p1 -p p2) ≤ MAX (deg p1) (deg p2) +Proof + once_rewrite_tac[poly_sub_def] + >> qspecl_then [‘p1’, ‘--p p2’] assume_tac deg_add_poly + >> gs[deg_poly_neg] +QED + +Theorem deg_mul_poly: + ∀ p1 p2. + deg (p1 *p p2) ≤ + if (zerop p1 ∨ zerop p2) then 0 else deg p1 + deg p2 +Proof + Induct_on ‘p1’ + >> rpt strip_tac + >> gs[zerop_def] + >- gs[deg_def, reduce_def, mul_0_left] + >> cond_cases_tac >> gs[] + >- ( gs[poly_mul_def] + >> Cases_on ‘h=0’ + >- ( gs[poly_mul_cst_0, poly_add_rid] + >> gs[reduce_def] + >> Cases_on ‘reduce p1 = []’ + >- ( gs[] >> Cases_on ‘p1 = []’ + >- gs[deg_def, reduce_def, LENGTH] + >> gs[] >> gs[reduce_def] + >> ‘reduce (p1 *p p2) = []’ by + ( gs[poly_mul_reduced] >> irule mult_zerop_l + >> gs[zerop_def] + ) + >> gs[deg_def, reduce_def, LENGTH] + ) + >> gs[] + ) + >> Cases_on ‘p1 = []’ + >- gs[reduce_def] + >> gs[poly_add_def] >> gs[reduce_def] + >> ‘reduce (0::(p1 *p p2)) = []’ by + ( gs[reduce_def] >> Cases_on ‘reduce p1 = []’ + >- gs[] + >> gs[] + ) + >> gs[reduce_add_zero_r, poly_mul_cst_reduced] + >> gs[deg_of_const_mul] + >> last_x_assum $ qspec_then ‘p2’ assume_tac + >> ‘reduce p1 = []’ by + ( gs[reduce_def] >> Cases_on ‘reduce p1 = []’ + >- gs[] + >> gs[] + ) + >> gs[] >> gs[deg_def] + >> gs[reduce_def] + ) + >- ( gs[poly_mul_def] + >> Cases_on ‘h=0’ + >- ( gs[poly_mul_cst_0, poly_add_rid] + >> Cases_on ‘p1 = []’ + >- gs[reduce_def, deg_def, LENGTH] + >> gs[] + >> ‘reduce (0::(p1 *p p2)) = []’ by + ( gs[reduce_def] + >> ‘reduce (p1 *p p2) = []’ by + ( gs[poly_mul_reduced] >> irule mult_zerop_r + >> gs[zerop_def] + ) + >> gs[] + ) + >> gs[deg_def, reduce_def, LENGTH] + ) + >> gs[] >> Cases_on ‘p1 = []’ + >- ( gs[poly_add_def] + >> ‘reduce (poly_add_aux (h *c p2) []) = reduce (h *c p2)’ + by ( irule reduce_add_zero_r >> gs[reduce_def] ) + >> gs[poly_mul_cst_reduced,deg_of_const_mul ] + >> gs[deg_def] + ) + >> gs[poly_add_def] + >> ‘reduce (0::(p1 *p p2)) = []’ by + ( gs[reduce_def] + >> ‘reduce (p1 *p p2) = []’ by + ( gs[poly_mul_reduced] >> irule mult_zerop_r + >> gs[zerop_def] + ) + >> gs[] + ) + >> gs[reduce_add_zero_r, poly_mul_cst_reduced] + >> gs[deg_of_const_mul] + >> gs[deg_def] + ) + >> gs[poly_mul_def] + >> Cases_on ‘p1 = []’ + >- ( gs[poly_add_lid, poly_mul_cst_reduced] + >> Cases_on ‘h=0’ + >- ( gs[poly_mul_cst_0] >> gs[deg_def, reduce_def] ) + >> gs[deg_of_const_mul] + >> ‘deg [h] = 0’ by gs[deg_def, reduce_def, LENGTH] + >> gs[] + ) + >> gs[] + >> last_x_assum $ qspec_then ‘p2’ assume_tac + >> gs[] + >> Cases_on ‘reduce p1 = []’ + >- ( gs[poly_add_def] + >> ‘p1 *p p2 = []’ by + ( irule mult_zerop_l >> gs[zerop_def] ) + >> gs[] + >> ‘reduce (poly_add_aux t []) = reduce t’ by + ( irule reduce_add_zero_r >> gs[reduce_def] ) + >> gs[poly_add_aux_lid] + >> Cases_on ‘h=0’ + >- ( gs[poly_mul_cst_0] >> gs[reduce_def, deg_def] ) + >> ‘ h *c p2 ≠ []’ by + gs[poly_mul_cst_def, reduce_p_poly_mul_holds_not] + >> gs[] + >> gs[poly_mul_cst_reduced] + >> gs[deg_of_const_mul] + >> ‘deg (h :: p1) = 0’ by gs[deg_def, reduce_def] + >> gs[] + ) + >> irule LESS_EQ_TRANS + >> qexists_tac ‘MAX (deg (h *c p2)) (deg (0::(p1 *p p2)))’ + >> gs[deg_add_poly] + >> conj_tac + >- ( + Cases_on ‘h = 0’ >> gs[poly_mul_cst_0, deg_of_const_mul, deg_def, reduce_def]) + >> gs[deg_def, reduce_def] + >> cond_cases_tac >> gs[] + >> irule LESS_EQ_TRANS + >> qexists_tac ‘SUC (1 + (LENGTH (reduce p1) - 1 + (LENGTH (reduce p2) - 1)))’ + >> gs[] + >> once_rewrite_tac [LESS_OR_EQ] >> DISJ2_TAC >> gs[SUC_ONE_ADD] + >> ‘0 < LENGTH (reduce p1) ∧ 0 < LENGTH (reduce p2)’ by gs[length_gt_0] + >> gs[] +QED + +Theorem reduce_monom_0: + reduce (monom n [0]) = [] +Proof + Induct_on ‘n’ >> gs[reduce_def, monom_def] +QED + +Theorem deg_monom_0: + deg (monom n [0]) = 0 +Proof + gs[monom_def] + >> Induct_on ‘n’ + >> gs[monom_def, deg_def, reduce_def] + >> cond_cases_tac + >> gs[LENGTH, reduce_monom_0] +QED + +Theorem deg_coeff_zerop: + deg p = 0 ∧ + coeff p 0 = 0 ⇒ + zerop p +Proof + rpt strip_tac >> CCONTR_TAC + >> gs[zerop_def, deg_def] + >> Cases_on ‘reduce p’ >> gs[] + >> ‘t = []’ by (Cases_on ‘t’ >> gs[]) + >> VAR_EQ_TAC >> gs[coeff_def] + >> Cases_on ‘p’ >> gs[reduce_def] + >> Cases_on ‘reduce t’ >> gs[oEL_def] +QED + +Theorem poly_sub_id: + ∀ p1. p1 -p p1 = [] +Proof + Induct_on ‘p1’ >> gs[poly_sub_def, poly_add_rid, reduce_def, + poly_neg_def, poly_mul_cst_def, poly_mul_cst_aux_def] + >> rpt strip_tac + >> gs[poly_add_def] + >> cond_cases_tac >> gs[] + >- ( + cond_cases_tac >> gs[poly_add_aux_lid, poly_add_aux_def, reduce_def] + >> ‘h + -1 * h = 0’ by real_tac + >> gs[]) + >> ‘h + -1 * h = 0’ by real_tac + >> gs[poly_add_aux_def, reduce_def] +QED + +Theorem poly_add_comm: + ∀ p1 p2. + p1 +p p2 = p2 +p p1 +Proof + Induct_on ‘p1’ >> gs[poly_add_def, poly_add_aux_def, poly_add_aux_lid] + >> rpt strip_tac + >> Cases_on ‘p2’ >> gs[poly_add_aux_def, reduce_def] + >> ‘h + h' = h' + h’ by gs[REAL_ADD_COMM] + >> pop_assum $ once_rewrite_tac o single + >> pop_assum $ qspec_then ‘t’ $ once_rewrite_tac o single + >> gs[] +QED + +Theorem reduce_add_l: + ∀ p1 p2. reduce p1 +p p2 = p1 +p p2 +Proof + Induct_on ‘p1’ >> gs[reduce_def, poly_add_def, poly_add_aux_def, poly_add_rid] + >> rpt strip_tac >> cond_cases_tac >> gs[] + >- ( + cond_cases_tac >> gs[] + >> last_x_assum $ qspec_then ‘p2’ assume_tac >> gs[poly_add_aux_def] + >> pop_assum $ once_rewrite_tac o single o GSYM + >> Cases_on ‘p2’ >> gs[reduce_def] + >> cond_cases_tac >> gs[reduce_add_zero_l]) + >> Cases_on ‘p2’ >> gs[poly_add_aux_lid, reduce_def, reduce_idempotent, + poly_add_aux_def] +QED + +Theorem reduce_add_r = ONCE_REWRITE_RULE [poly_add_comm] reduce_add_l + +Theorem reduce_add_aux_l = ONCE_REWRITE_RULE [poly_add_def] reduce_add_l + +Theorem reduce_add_aux_r = ONCE_REWRITE_RULE [poly_add_def] reduce_add_r + +Theorem reduce_poly_reduced: + ∀ p x q. reduce p = x :: q ⇒ reduce q = q +Proof + Induct_on ‘p’ >> gs[reduce_def] + >> rpt strip_tac >> Cases_on ‘reduce p’ >> gs[] >> rpt VAR_EQ_TAC + >- (Cases_on ‘h = 0’ >> gs[reduce_def]) + >> gs[reduce_idempotent] +QED + +Theorem poly_add_assoc: + ∀ p1 p2 p3. + p1 +p (p2 +p p3) = (p1 +p p2) +p p3 +Proof + Induct_on ‘p1’ + >- ( + Cases_on ‘p2’ >> rpt strip_tac + >- gs[poly_add_def, poly_add_aux_lid, poly_add_aux_def, reduce_idempotent, + reduce_def] + >> gs[poly_add_rid, poly_add_reduced, reduce_add_l]) + >> rpt strip_tac >> gs[poly_add_def, reduce_add_aux_l, reduce_add_aux_r, poly_add_aux_def] + >> Cases_on ‘p2’ >> gs[poly_add_aux_lid, poly_add_aux_def] + >- ( + Cases_on ‘p3’ >> gs[poly_add_aux_lid, poly_add_aux_def, reduce_def] + >> Cases_on ‘reduce t’ >> gs[reduce_add_zero_r] + >- (Cases_on ‘h' = 0’ >> gs[reduce_def, poly_add_aux_lid]) + >> gs[reduce_def] + >> ‘reduce (poly_add_aux p1 t) = reduce (poly_add_aux p1 (h'' :: t'))’ + by (qpat_x_assum ‘reduce _ = _’ $ once_rewrite_tac o single o GSYM + >> gs[reduce_add_aux_r]) + >> pop_assum $ rewrite_tac o single + >> Cases_on ‘h + h' = 0’ >> gs[]) + >> Cases_on ‘p3’ >> gs[poly_add_aux_lid, poly_add_aux_def, reduce_def] + >- ( + Cases_on ‘reduce t’ >> gs[reduce_add_zero_r] + >- (Cases_on ‘h' = 0’ >> gs[reduce_def, poly_add_aux_lid]) + >> ‘reduce (poly_add_aux p1 t) = reduce (poly_add_aux p1 (h'' :: t'))’ + by (qpat_x_assum ‘reduce _ = _’ $ once_rewrite_tac o single o GSYM + >> gs[reduce_add_aux_r]) + >> pop_assum $ rewrite_tac o single + >> Cases_on ‘h + h' = 0’ >> gs[reduce_def]) + >> first_x_assum $ qspecl_then [‘t’, ‘t'’] $ rewrite_tac o single o GSYM + >> Cases_on ‘reduce (poly_add_aux t t')’ >> gs[reduce_add_zero_r] + >- ( + Cases_on ‘h' + h'' = 0’ >> gs[reduce_def, poly_add_aux_lid] + >- ( + Cases_on ‘reduce p1’ >> gs[] >> TRY real_tac + >> Cases_on ‘h = 0’ >> gs[] + >> ‘h + h' + h'' ≠ 0’ by real_tac + >> gs[] + >> real_tac) + >> Cases_on ‘reduce p1’ >> gs[REAL_ADD_ASSOC]) + >> ‘reduce (poly_add_aux p1 (poly_add_aux t t')) = reduce (poly_add_aux p1 (h'3' :: t''))’ + by (qpat_x_assum ‘reduce _ = _’ $ once_rewrite_tac o single o GSYM + >> gs[reduce_add_aux_r]) + >> pop_assum $ rewrite_tac o single + >> gs[reduce_def] + >> rpt (cond_cases_tac >> gs[REAL_ADD_ASSOC]) +QED + +Theorem poly_mul_zero_r: + ∀p. p *p [0] = [] +Proof + Induct_on ‘p’ + >- gs[poly_mul_def] + >> rpt strip_tac + >> gs[poly_mul_def] + >> cond_cases_tac + >- ( gs[poly_add_lid, poly_mul_cst_reduced, poly_mul_cst_def] + >> gs[poly_mul_cst_aux_def, reduce_def] + ) + >> gs[poly_add_lid, poly_mul_cst_reduced] + >> gs[poly_mul_cst_def, poly_mul_cst_aux_def, reduce_def] +QED + +Theorem poly_mul_cst_mul_l: + ∀t. reduce (poly_mul_cst_aux 0 t) = [] +Proof + gen_tac + >> ‘reduce (poly_mul_cst_aux 0 t) = 0 *c t’ by gs[poly_mul_cst_def] + >> gs[poly_mul_cst_0] +QED + +Theorem poly_mul_scal: + ∀t h. t *p [h] = reduce (poly_mul_cst_aux h t) +Proof + Induct_on ‘t’ + >- gs[mul_0_left, poly_mul_cst_aux_def, reduce_def] + >> rpt strip_tac + >> gs[poly_mul_def, poly_mul_cst_def, poly_mul_cst_aux_def] + >> cond_cases_tac + >- ( gs[poly_add_lid, reduce_def] + >> cond_cases_tac + >- gs[reduce_def, poly_mul_cst_aux_def] + >> gs[poly_mul_cst_aux_def, reduce_def] + ) + >> gs[reduce_def] + >> cond_cases_tac + >- gs[poly_add_rid, reduce_def, reduce_idempotent] + >> gs[poly_add_def, poly_add_aux_def, reduce_def, reduce_idempotent] +QED + +Theorem poly_shift_add: + ∀p q. reduce (poly_add_aux p q) ≠ [] ⇒ + 0 :: (p +p q) = 0 :: p +p 0::q +Proof + rpt strip_tac + >> gs[poly_add_def, poly_add_aux_def, reduce_def] +QED + +Theorem poly_mul_scal_in: + ∀ h h' p. h ≠ 0 ∧ h' ≠ 0 ⇒ h *c h'::p = (h * h') :: (h *c p) +Proof + rpt strip_tac + >> gs[poly_mul_cst_def, poly_mul_cst_aux_def, reduce_def] + >> cond_cases_tac >> gs[] +QED + +Theorem poly_mul_cst_scal_comm: + ∀h c p. h *c (c *c p) = c *c (h *c p) +Proof + rpt strip_tac + >> Cases_on ‘h=0’ + >- gs[poly_mul_cst_0, poly_cst_mult_nul] + >> Cases_on ‘c=0’ + >- gs[poly_mul_cst_0, poly_cst_mult_nul] + >> gs[poly_mul_cst_def] + >> Induct_on ‘p’ + >- gs[poly_mul_cst_aux_def, reduce_def] + >> gs[poly_mul_cst_aux_def, reduce_def] + >> gen_tac + >> Cases_on ‘reduce p = []’ + >- ( gs[reduce_p_poly_mul_holds] + >> cond_cases_tac + >> gs[poly_mul_cst_aux_def, reduce_def] + ) + >> gs[reduce_p_poly_mul_holds_not, poly_mul_cst_aux_def, reduce_def] +QED + +Theorem poly_add_aux_comm: + ∀ p1 p2. reduce (poly_add_aux p1 p2) = reduce (poly_add_aux p2 p1) +Proof + rpt strip_tac + >> ‘reduce (poly_add_aux p1 p2) = p1 +p p2’ by gs[poly_add_def] + >> ‘reduce (poly_add_aux p2 p1) = p2 +p p1’ by gs[poly_add_def] + >> gs[poly_add_comm] +QED + +Theorem poly_add_aux_reduce_add: + ∀p t. reduce (poly_add_aux t p) = reduce (poly_add_aux t (reduce p)) +Proof + Induct_on ‘p’ + >- gs[reduce_def] + >> rpt strip_tac + >> ‘ reduce (poly_add_aux t (h::p)) = reduce (poly_add_aux (h::p) t)’ + by gs[poly_add_aux_comm] + >> pop_assum $ rewrite_tac o single + >> ‘reduce (poly_add_aux t (reduce (h::p))) = + reduce (poly_add_aux (reduce (h::p)) t)’ by gs[poly_add_aux_comm] + >> pop_assum $ rewrite_tac o single + >> gs[reduce_def, poly_add_aux_def] + >> Cases_on ‘t’ + >- ( gs[reduce_def] + >> cond_cases_tac + >- (gs[poly_add_aux_lid] >> cond_cases_tac >> gs[reduce_def]) + >> gs[poly_add_aux_lid, poly_add_aux_def, reduce_def, reduce_idempotent] + ) + >> gs[reduce_def] + >> Cases_on ‘reduce p = []’ + >- ( gs[reduce_add_zero_l] + >> Cases_on ‘h=0’ + >- gs[poly_add_aux_def, reduce_def] + >> gs[poly_add_aux_def, reduce_def] + ) + >> gs[poly_add_aux_def, reduce_def] + >> last_x_assum $ qspec_then ‘t'’ assume_tac + >> ‘reduce (poly_add_aux (reduce p) t') = + reduce (poly_add_aux t' (reduce p))’ by gs[poly_add_aux_comm] + >> pop_assum $ rewrite_tac o single + >> ‘reduce (poly_add_aux p t') = reduce (poly_add_aux t' p)’ by + gs[poly_add_aux_comm] + >> pop_assum $ rewrite_tac o single + >> gs[] +QED + +Theorem poly_mul_cst_aux_reduce_mul: + ∀ c p. reduce (poly_mul_cst_aux c p) = + reduce (poly_mul_cst_aux c (reduce p)) +Proof + rpt strip_tac + >> ‘ reduce (poly_mul_cst_aux c p) = c *c p’ by gs[poly_mul_cst_def] + >> pop_assum $ rewrite_tac o single + >> ‘reduce (poly_mul_cst_aux c (reduce p)) = c *c (reduce p)’ by + gs[poly_mul_cst_def] + >> pop_assum $ rewrite_tac o single + >> gs[poly_mul_cst_reduce] +QED + +Theorem poly_add_aux_cst_mul_distrib: + ∀ c t t'. + reduce (poly_add_aux (reduce (poly_mul_cst_aux c t)) + (reduce (poly_mul_cst_aux c t'))) = + reduce (poly_mul_cst_aux c (reduce (poly_add_aux t t'))) +Proof + gen_tac + >> Cases_on ‘c=0’ + >- gs[poly_mul_cst_mul_l, poly_add_aux_lid, reduce_def] + >> Induct_on ‘t’ + >- ( gs[poly_add_aux_def, poly_mul_cst_aux_def, reduce_def, reduce_idempotent] + >> gen_tac >> gs[GSYM poly_mul_cst_aux_reduce_mul] + ) + >> gs[poly_mul_cst_aux_def, poly_add_aux_def, reduce_def] + >> rpt strip_tac + >> Cases_on ‘t'’ + >- ( gs[reduce_def] + >> Cases_on ‘reduce t = []’ + >- ( gs[reduce_p_poly_mul_holds] + >> Cases_on ‘h=0’ + >- gs[poly_add_aux_def, poly_add_aux_lid, poly_mul_cst_aux_def, + reduce_def] + >> gs[poly_mul_cst_aux_def, reduce_def, poly_add_aux_lid] + ) + >> gs[reduce_p_poly_mul_holds_not, poly_mul_cst_aux_def, reduce_def, + poly_add_aux_lid, reduce_idempotent, + GSYM poly_mul_cst_aux_reduce_mul] + ) + >> gs[reduce_def] + >> Cases_on ‘reduce t = []’ + >- ( gs[reduce_p_poly_mul_holds, reduce_add_zero_l, poly_add_aux_def] + >> Cases_on ‘reduce t'' = []’ + >- ( gs[] + >> Cases_on ‘h=0’ + >- ( gs[poly_add_aux_def, poly_mul_cst_aux_def, reduce_def, + reduce_p_poly_mul_holds] + >> Cases_on ‘h'=0’ + >- gs[poly_mul_cst_aux_def, reduce_def] + >> gs[poly_mul_cst_aux_def, reduce_def] + ) + >> gs[poly_add_aux_def, poly_mul_cst_aux_def, reduce_def, + reduce_p_poly_mul_holds] + >> Cases_on ‘h'=0’ + >- gs[reduce_def, poly_mul_cst_aux_def] + >> gs[reduce_def, poly_mul_cst_aux_def] + >> Cases_on ‘h + h' = 0’ + >- ( gs[poly_mul_cst_aux_def, reduce_def] + >> ‘c * h + c * h' = 0’ by + ( ‘c * h + c * h' = c * (h + h') ’ by REAL_ARITH_TAC + >> gs[] + ) + >> gs[] + ) + >> gs[poly_mul_cst_aux_def, reduce_def] + >> ‘c * h + c * h' ≠ 0’ by + ( ‘c * h + c * h' = c * (h + h') ’ by REAL_ARITH_TAC + >> gs[] + ) + >> gs[] >> REAL_ARITH_TAC + ) + >> gs[poly_mul_cst_aux_def, reduce_def] + >> ‘reduce (poly_mul_cst_aux c (reduce t'')) ≠ []’ by + gs[reduce_p_poly_mul_holds_not, reduce_idempotent] + >> gs[reduce_p_poly_mul_holds_not] + >> Cases_on ‘h=0’ + >- gs[poly_add_aux_def, reduce_def] + >> gs[poly_add_aux_def, reduce_def] + >> REAL_ARITH_TAC + ) + >> gs[reduce_p_poly_mul_holds_not, poly_add_aux_def, poly_mul_cst_aux_def, + reduce_def] + >> Cases_on ‘reduce (poly_mul_cst_aux c t)’ + >- gs[reduce_p_poly_mul_holds_not] + >> gs[] + >> Cases_on ‘reduce t'' = []’ + >- ( gs[reduce_p_poly_mul_holds, reduce_add_zero_r, poly_mul_cst_aux_def, + reduce_def, GSYM poly_mul_cst_aux_reduce_mul, + reduce_p_poly_mul_holds_not ] + >> Cases_on ‘ h' = 0 ’ + >- ( gs[reduce_def] + >> Cases_on ‘reduce t' = []’ + >- ( gs[] + >> Cases_on ‘h'' = 0’ + >- ( gs[] + >> qpat_x_assum ‘ ∀t'³'. _ ’ $ qspec_then ‘t''’ assume_tac + >> gs[poly_add_aux_def] + >> Cases_on ‘reduce (poly_mul_cst_aux c t'')’ + >- ( gs[reduce_def] + >> ‘reduce (poly_mul_cst_aux c (poly_add_aux t t'')) = + reduce (poly_mul_cst_aux c + (reduce (poly_add_aux t t'')))’ + by gs[GSYM poly_mul_cst_aux_reduce_mul] + >> gs[reduce_add_zero_r] + >> gs[GSYM poly_mul_cst_aux_reduce_mul] + ) + >> gs[reduce_def, reduce_p_poly_mul_holds] + ) + >> gs[poly_add_aux_def] + >> qpat_x_assum ‘ ∀t'³'. _ ’ $ qspec_then ‘t''’ assume_tac + >> Cases_on ‘reduce (poly_mul_cst_aux c t'')’ + >- ( gs[reduce_def] + >> ‘reduce (poly_mul_cst_aux c (poly_add_aux t t'')) = + reduce (poly_mul_cst_aux c (reduce (poly_add_aux t t'')))’ + by gs[GSYM poly_mul_cst_aux_reduce_mul] + >> gs[reduce_add_zero_r] + >> gs[GSYM poly_mul_cst_aux_reduce_mul] + ) + >> gs[reduce_def, reduce_p_poly_mul_holds] + ) + >> gs[] + >> qpat_x_assum ‘ ∀t'³'. _ ’ $ qspec_then ‘t''’ assume_tac + >> gs[poly_add_aux_def] + >> Cases_on ‘reduce (poly_mul_cst_aux c t'')’ + >- ( gs[reduce_def] + >> ‘reduce (poly_mul_cst_aux c (poly_add_aux t t'')) = + reduce (poly_mul_cst_aux c (reduce (poly_add_aux t t'')))’ + by gs[GSYM poly_mul_cst_aux_reduce_mul] + >> gs[reduce_add_zero_r] + >> gs[GSYM poly_mul_cst_aux_reduce_mul] + ) + >> gs[reduce_def, reduce_p_poly_mul_holds] + ) + >> gs[reduce_def, poly_add_aux_lid] + >> Cases_on ‘reduce t' = []’ + >- ( gs[] + >> Cases_on ‘h'' = 0’ + >- ( gs[] + >> qpat_x_assum ‘ ∀t'³'. _ ’ $ qspec_then ‘t''’ assume_tac + >> gs[poly_add_aux_def] + >> Cases_on ‘reduce (poly_mul_cst_aux c t'')’ + >- ( gs[reduce_def] + >> ‘reduce (poly_mul_cst_aux c (poly_add_aux t t'')) = + reduce (poly_mul_cst_aux c + (reduce (poly_add_aux t t'')))’ + by gs[GSYM poly_mul_cst_aux_reduce_mul] + >> gs[reduce_add_zero_r] + >> gs[GSYM poly_mul_cst_aux_reduce_mul] + ) + >> gs[reduce_def, reduce_p_poly_mul_holds] + ) + >> gs[] >> conj_tac + >- REAL_ARITH_TAC + >> qpat_x_assum ‘ ∀t'³'. _ ’ $ qspec_then ‘t''’ assume_tac + >> gs[poly_add_aux_def] + >> Cases_on ‘reduce (poly_mul_cst_aux c t'')’ + >- ( gs[reduce_def] + >> ‘reduce (poly_mul_cst_aux c (poly_add_aux t t'')) = + reduce (poly_mul_cst_aux c (reduce (poly_add_aux t t'')))’ + by gs[GSYM poly_mul_cst_aux_reduce_mul] + >> gs[reduce_add_zero_r] + >> gs[GSYM poly_mul_cst_aux_reduce_mul] + ) + >> gs[reduce_def, reduce_p_poly_mul_holds] + ) + >> gs[reduce_def, poly_add_aux_lid] + >> conj_tac + >- REAL_ARITH_TAC + >> qpat_x_assum ‘ ∀t'³'. _ ’ $ qspec_then ‘t''’ assume_tac + >> gs[poly_add_aux_def] + >> Cases_on ‘reduce (poly_mul_cst_aux c t'')’ + >- ( gs[reduce_def] + >> ‘reduce (poly_mul_cst_aux c (poly_add_aux t t'')) = + reduce (poly_mul_cst_aux c (reduce (poly_add_aux t t'')))’ + by gs[GSYM poly_mul_cst_aux_reduce_mul] + >> gs[reduce_add_zero_r] + >> gs[GSYM poly_mul_cst_aux_reduce_mul] + ) + >> gs[reduce_def, reduce_p_poly_mul_holds] + ) + >> gs[reduce_p_poly_mul_holds_not, reduce_def] + >> Cases_on ‘reduce (poly_add_aux t t'') = []’ + >- ( gs[reduce_p_poly_mul_holds, reduce_idempotent] + >> Cases_on ‘h + h' = 0’ + >- ( gs[poly_mul_cst_aux_def, reduce_def] + >> ‘c * h + c * h' = 0’ by + ( ‘c * h + c * h' = c * (h + h') ’ by REAL_ARITH_TAC + >> gs[] + ) + >> gs[] + ) + >> gs[poly_mul_cst_aux_def, reduce_def] + >> ‘c * h + c * h' ≠ 0’ by + ( ‘c * h + c * h' = c * (h + h') ’ by REAL_ARITH_TAC + >> gs[] + ) + >> gs[] >> REAL_ARITH_TAC + ) + >> gs[reduce_p_poly_mul_holds_not, reduce_idempotent] + >> gs[poly_mul_cst_aux_def, reduce_def] + >> gs[reduce_p_poly_mul_holds_not, reduce_idempotent] + >> REAL_ARITH_TAC +QED + +Theorem poly_mul_cst_distrib: + ∀ c p1 p2. + c *c p1 +p c *c p2 = c *c (p1 +p p2) +Proof + Induct_on ‘p1’ >> rpt strip_tac + >> ‘c *c [] = []’ by gs[poly_mul_cst_def, poly_mul_cst_aux_def, reduce_def] + >- gs[poly_add_rid, poly_mul_cst_reduced, poly_mul_cst_reduce] + >> Cases_on ‘c=0’ + >- gs[poly_mul_cst_0, poly_add_lid, reduce_def] + >> Cases_on ‘p2’ + >- gs[poly_add_rid, poly_add_lid, poly_mul_cst_reduced, poly_mul_cst_reduce] + >> rename1 ‘h1:: p1 +p h2 :: p2’ + >> ‘h1::p1 +p h2::p2 = reduce ((h1 + h2) :: (p1 +p p2))’ + by gs[poly_add_def, poly_add_aux_def, reduce_def, reduce_idempotent] + >> pop_assum $ once_rewrite_tac o single + >> ‘c *c (h1::p1) = reduce(c*h1 :: (c *c p1))’ + by gs[poly_mul_cst_def, poly_mul_cst_aux_def, reduce_def, reduce_idempotent] + >> pop_assum $ once_rewrite_tac o single + >> ‘c *c (h2::p2) = reduce(c*h2 :: (c *c p2))’ + by gs[poly_mul_cst_def, poly_mul_cst_aux_def, reduce_def, reduce_idempotent] + >> pop_assum $ once_rewrite_tac o single + >> gs[reduce_add_l, reduce_add_r] + >> qmatch_goalsub_abbrev_tac ‘c * h1 :: poly1 +p c * h2 :: poly2’ + >> ‘c * h1 :: poly1 +p c * h2 :: poly2 = + reduce (c * h1 + c * h2 :: (poly1 +p poly2))’ + by gs[poly_add_def, poly_add_aux_def, reduce_def, reduce_idempotent] + >> pop_assum $ once_rewrite_tac o single + >> unabbrev_all_tac + >> gs[reduce_def, poly_mul_cst_def, reduce_idempotent] + >> Cases_on ‘reduce (p1 +p p2)’ + >> gs[reduce_p_poly_mul_holds_not, reduce_p_poly_mul_holds] + >- ( + Cases_on ‘h1 + h2 = 0’ >> gs[] + >- (‘c * h1 + c * h2 = 0’ suffices_by gs[] + >> ‘c * (h1 + h2) = 0’ suffices_by real_tac + >> gs[]) + >> ‘c * h1 + c * h2 ≠ 0’ by ( + CCONTR_TAC >> gs[] + >>‘ c * (h1 + h2) = 0’ by real_tac + >> gs[]) + >> gs[reduce_def, poly_mul_cst_aux_def] + >> real_tac) + >> simp[Once poly_mul_cst_aux_def, reduce_def] + >> ‘reduce (poly_mul_cst_aux c (h::t)) ≠ []’ by ( + irule reduce_p_poly_mul_holds_not + >> first_assum $ once_rewrite_tac o single o GSYM + >> gs[reduce_idempotent]) + >> gs[] >> conj_tac >- real_tac + >> qpat_x_assum `reduce (_ +p _ ) = _` $ once_rewrite_tac o single o GSYM + >> gs[SIMP_RULE std_ss [poly_mul_cst_def] poly_mul_cst_reduce] +QED + +Theorem poly_mul_mul_cst: + ∀ c p1 p2. + p1 *p (c *c p2) = c *c (p1 *p p2) +Proof + gen_tac + >> Cases_on ‘c=0’ + >- gs[poly_mul_cst_0, mul_0_right] + >> Induct_on ‘p1’ + >- gs[mul_0_left, poly_cst_mult_nul] + >> gs[poly_mul_def] + >> Cases_on ‘p1= []’ + >- ( rpt strip_tac + >> gs[poly_add_lid, poly_mul_cst_reduced, poly_mul_cst_reduce] + >> gs[poly_mul_cst_scal_comm] + ) + >> gs[] + >> rpt strip_tac + >> ‘c *c (h *c p2 +p 0::(p1 *p p2)) = + c *c (h *c p2) +p c *c ( 0 :: (p1 *p p2))’ by + gs[poly_mul_cst_distrib] + >> pop_assum $ rewrite_tac o single + >> Cases_on ‘reduce (p1 *p p2) = []’ + >- ( gs[poly_mul_cst_scal_comm] + >> gs[poly_mul_cst_def, poly_mul_cst_aux_def, reduce_def, + reduce_p_poly_mul_holds, poly_add_lid] + ) + >> ‘0::(c *c (p1 *p p2)) = c *c 0::(p1 *p p2)’ by + ( gs[poly_mul_cst_def, poly_mul_cst_aux_def, reduce_def] + >> gs[reduce_p_poly_mul_holds_not] + ) + >> gs[poly_mul_cst_scal_comm] +QED + +Theorem poly_mul_cst_shift: + ∀ a b p. b ≠ 0 ∧ a ≠ 0 ⇒ + (a * b) *c p = a *c (b *c p) +Proof + gen_tac >> gen_tac + >> Induct_on ‘p’ + >- gs[poly_cst_mult_nul] + >> rpt strip_tac >> gs[poly_mul_cst_def, poly_mul_cst_aux_def, reduce_def] + >> Cases_on ‘reduce (poly_mul_cst_aux b p) = []’ + >- ( gs[reduce_p_poly_mul_holds, poly_mul_cst_aux_def, reduce_def] + >> cond_cases_tac + >- gs[poly_mul_cst_aux_def, reduce_def] + >> gs[poly_mul_cst_aux_def, reduce_def] + ) + >> gs[reduce_p_poly_mul_holds_not, poly_mul_cst_aux_def, reduce_def, + reduce_idempotent] +QED + +Theorem poly_mul_cst_pow: + ∀ c n p. + c pow n *c (c *c p) = c pow (n + 1) *c p +Proof + gen_tac + >> Cases_on ‘c=0’ + >- gs[poly_mul_cst_0, poly_cst_mult_nul, POW_0'] + >> gen_tac + >> Induct_on ‘n’ + >- ( strip_tac >> gs[pow0, mul_cst1, poly_mul_cst_reduced] ) + >> gs[GSYM SUC_ADD_SYM, pow] + >> gen_tac + >> pop_assum $ qspec_then ‘p’ assume_tac + >> gs[poly_mul_cst_shift] +QED + +Theorem reduce_add: + reduce (p1 +p p2) = p1 +p p2 +Proof + Induct_on ‘p1’ + >- gs[poly_add_def, poly_add_aux_def, reduce_def, reduce_idempotent] + >> strip_tac + >> gs[poly_add_def, poly_add_aux_def, reduce_idempotent] +QED + +Theorem reduce_mul_cst: + ∀ p c. reduce (c *c p) = c *c p +Proof + Induct_on ‘p’ >> gs[poly_mul_cst_def, reduce_def, poly_mul_cst_aux_def, reduce_idempotent] + >> rpt strip_tac + >> cond_cases_tac >> gs[reduce_def, reduce_idempotent] + >> cond_cases_tac >> gs[reduce_def] +QED + +Theorem reduce_neg = + REWRITE_RULE [PROVE [] “(A ⇔ T) ⇔ A”] $ SIMP_CONV std_ss [poly_neg_def, reduce_mul_cst] “reduce (--p p) = --p p” + +Theorem reduce_mul_poly: + ∀ p1 p2. + reduce (p1 *p p2) = p1 *p p2 +Proof + Induct_on ‘p1’ >> gs[poly_mul_def, reduce_def] + >> rpt strip_tac + >> cond_cases_tac >> gs[reduce_add] +QED + +Theorem evalPoly_app: + ∀ p1 p2 x. evalPoly (p1 ++ p2) x = evalPoly p1 x + evalPoly p2 x * x pow (LENGTH p1) +Proof + Induct_on ‘p1’ >> gs[evalPoly_def] + >> rpt strip_tac >> pop_assum kall_tac + >> gs[REAL_LDISTRIB, pow] + >> real_tac +QED + +Theorem compose_correct: + ∀ p q. evalPoly (compose p q) x = evalPoly p (evalPoly q x) +Proof + Induct_on ‘p’ >- gs[compose_def, evalPoly_def] + >> once_rewrite_tac[compose_def] + >> rewrite_tac [evalPoly_def, eval_simps, REAL_MUL_RZERO, REAL_ADD_RID] + >> gs[] +QED + +Theorem poly_neg_evals: + ∀p x. poly (--p p) x = - poly p x +Proof + gs[GSYM poly_compat, eval_simps] +QED + +Theorem poly_nill_left_add: + ∀ p x. poly ([] +p p) x = poly p x +Proof + gs[poly_add_rid] >> gs[GSYM poly_compat, reduce_preserving] +QED + +Theorem poly_reduce_evals: + ∀ p x. poly (reduce p) x = poly p x +Proof + gs[GSYM poly_compat, reduce_preserving] +QED + +Theorem poly_neg_neg_evals: + ∀ t. poly (--p (--p t)) = poly t +Proof + rpt strip_tac >> rewrite_tac[FUN_EQ_THM, GSYM poly_compat, eval_simps] + >> real_tac +QED + +Theorem poly_add_aux_evals: + ∀p t x. poly (poly_add_aux p t) x = poly p x + poly t x +Proof + Induct_on ‘p’ + >- gs[poly_add_aux_def, poly_def] + >> rpt strip_tac >> gs[poly_add_aux_def] + >> Cases_on ‘t’ + >- gs[poly_add_aux_lid, poly_def] + >> gs[poly_def] + >> ‘h + x * poly p x + (h' + x * poly t' x) = h + h' + + x * (poly p x + poly t' x)’ by REAL_ARITH_TAC + >> pop_assum $ rewrite_tac o single +QED + +Theorem poly_sub_evals: + ∀ p q x. poly (p -p q) x = poly p x - poly q x +Proof + gs[GSYM poly_compat, eval_simps] +QED + +Theorem poly_cst_evals: + ∀ p c x. c * poly p x = poly (c *c p) x +Proof + gs[GSYM poly_compat, eval_simps] +QED + +Theorem poly_shift_eval: + ∀p q. q ≠ [] ⇒ p ≠ [] ⇒ deg q < deg p ⇒ + poly (monom (deg p − deg q) [LAST p / LAST q]) x * poly q x = + poly (LAST p / LAST q *c monom (deg p − deg q) q) x +Proof + rpt strip_tac + >> assume_tac LESS_ADD + >> pop_assum $ qspecl_then [‘deg p’, ‘deg q’] assume_tac + >> res_tac + >> ‘deg p - deg q = p'’ by gs[] + >> pop_assum $ rewrite_tac o single + >> pop_assum kall_tac + >> pop_assum kall_tac + >> pop_assum kall_tac + >> Induct_on ‘p'’ + >- ( + gs[monom_def, poly_def] + >> gs[poly_cst_evals, real_div] + ) + >> gs[monom_def, poly_def, GSYM poly_cst_evals] + >> gs[poly_def, GSYM REAL_MUL_ASSOC] >> REAL_ARITH_TAC +QED + +Theorem deg_p_not_0: + ∀p. deg p ≠ 0 ⇒ p ≠ [] +Proof + gen_tac + >> rpt strip_tac >> CCONTR_TAC + >> ‘deg p = 0’ suffices_by gs[] + >> VAR_EQ_TAC + >> gs[deg_def, reduce_def, LENGTH] +QED + +(** Theorem on Euclidean division **) +Theorem poly_const_2_mul: + ∀ p a b x. + poly (a ## poly_mul_cst_aux b p) x = + poly (poly_mul_cst_aux (a * b) p) x +Proof + Induct_on ‘p’ + >- ( rpt strip_tac >> gs[poly_mul_cst_aux_def, POLY_CMUL_CLAUSES] ) + >> rpt strip_tac >> gs[poly_mul_cst_aux_def, poly_cmul_def] + >> gs[REAL_MUL_ASSOC, poly_def] +QED + +Theorem poly_cst_one_mul: + ∀p x. poly (poly_mul_cst_aux 1 p) x = poly p x +Proof + Induct_on ‘p’ + >- ( gen_tac >> gs[poly_mul_cst_aux_def] ) + >> rpt strip_tac + >> gs[poly_mul_cst_aux_def, poly_def] +QED + +Theorem poly_one_mul: + ∀ p q. poly (p + 1 ## q) = poly (p + q) +Proof + gen_tac + >> Induct_on ‘q’ + >- gs[POLY_CMUL_CLAUSES] + >> gen_tac + >> gs[poly_cmul_def] >> gs[FUN_EQ_THM] >> gen_tac + >> gs[POLY_ADD, poly_def] +QED + +Theorem nonzero_coeff: + ~ zerop p ⇒ + coeff p (deg p) ≠ 0 +Proof + Induct_on ‘p’ >> gs[deg_def, coeff_def, zerop_def, oEL_def, reduce_def] + >> Cases_on ‘reduce p’ >> gs[] + >- ( + rpt strip_tac + >> Cases_on ‘h = 0’ >> gs[]) + >> ‘SUC (SUC (LENGTH t)) - 2 = LENGTH t’ by gs[] + >> pop_assum $ rewrite_tac o single >> gs[] +QED + +Theorem normalized_normal: + ~ zerop p ⇒ + coeff ((inv (coeff p (deg p))) *c p) (deg ((inv (coeff p (deg p))) *c p)) = 1 +Proof + Induct_on ‘p’ + >- gs[zerop_def, coeff_def, deg_def, oEL_def, reduce_def, poly_mul_cst_0] + >> rpt strip_tac + >> gs[coeff_cst_mul] + >> Cases_on ‘reduce p’ + >- ( + gs[deg_def, reduce_def, zerop_def] + >> ‘h ≠ 0’ by (Cases_on ‘h = 0’ >> gs[]) + >> ‘coeff (h::p) 0 = h’ by (gs[coeff_def, oEL_def]) + >> ‘inv h ≠ 0’ by (CCONTR_TAC >> gs[]) + >> gs o single $ SIMP_RULE std_ss [deg_def] deg_of_const_mul + >> gs[reduce_def, REAL_MUL_LINV]) + >> ‘0 < deg (h::p)’ by gs[deg_def, reduce_def] + >> gs[coeff_cons] + >> ‘~ zerop p’ by gs[zerop_def] + >> imp_res_tac nonzero_coeff + >> gs[deg_of_const_mul, coeff_cons] +QED + +Theorem nonzero_normalize: + ~ zerop p ⇒ + ~ zerop ((inv (coeff p (deg p))) *c p) +Proof + Induct_on ‘p’ + >- gs[zerop_def, reduce_def] + >> rpt strip_tac + >> Cases_on ‘reduce p = []’ + >- ( gs[zerop_def, reduce_def, coeff_def, poly_mul_cst_def, oEL_def, + poly_mul_cst_aux_def] + >> ‘deg (h :: p) = 0’ by + ( gs[deg_def, reduce_def] + >> cond_cases_tac >> gs[] + ) + >> gs[] + >> Cases_on ‘h=0’ + >- gs[] + >> gs[reduce_p_poly_mul_holds] + >> ‘h⁻¹ * h = &1 ’ by gs[REAL_MUL_LINV] + >> gs[reduce_def] + ) + >> ‘0 < deg (h::p)’ by gs[deg_def, reduce_def, length_gt_0] + >> ‘ coeff (h::p) (deg (h::p)) = coeff p (deg p)’ by gs[coeff_cons] + >> ‘¬zerop p’ by gs[zerop_def] + >> gs[poly_mul_cst_def, poly_mul_cst_aux_def, reduce_def] + >> Cases_on ‘reduce (poly_mul_cst_aux (coeff p (deg p))⁻¹ p) = []’ + >- gs[zerop_def, reduce_def] + >> gs[zerop_def, reduce_def, reduce_idempotent] +QED + +Theorem nonzero_last_coeff: + ~ zerop p2 ⇒ + coeff p2 (deg p2) ≠ 0 +Proof + Induct_on ‘p2’ + >- gs[zerop_def, reduce_def] + >> rpt strip_tac + >> Cases_on ‘reduce p2 = []’ + >- ( gs[zerop_def, reduce_def, coeff_def, oEL_def] + >> ‘deg (h :: p2) = 0’ by + ( gs[deg_def, reduce_def] + >> cond_cases_tac >> gs[] + ) + >> gs[] + ) + >> ‘0 < deg (h::p2)’ by gs[deg_def, reduce_def, length_gt_0] + >> ‘ coeff (h::p2) (deg (h::p2)) = coeff p2 (deg p2)’ by gs[coeff_cons] + >> ‘¬zerop p2’ by gs[zerop_def] + >> gs[] +QED + +Theorem poly_eq_eval_eq: + ∀ p1 p2. + p1 = p2 ⇒ evalPoly p1 = evalPoly p2 +Proof + gs[] +QED + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/realPolyScript.sml b/floatingPoint/tools/dandelion/realPolyScript.sml new file mode 100644 index 0000000000..310c48b38f --- /dev/null +++ b/floatingPoint/tools/dandelion/realPolyScript.sml @@ -0,0 +1,439 @@ +(** + Definition of datatype for real-valued polynomials + + We formalize univariate polynomials only. Currently HOL4 only supports + derivatives of univariate polynomials, and therefore adding + multivariate polynomials would significantly increase the complexity + of the project. + Inspired by and proven equivalent to the definitions of Harrison +**) +open realTheory realLib RealArith bossLib polyTheory; +open renameTheory; +open bitArithLib preambleDandelion; + +val _ = new_theory "realPoly"; + +(** + We follow the "standard" formalizations used in the HOL family, + a polynomial p = c_0 * x^0 + c_1 * x^1 + c_2 * x^2 + ... + is expressed as the list of real numbers [c_0; c_1; c_2; ...] +**) +Type poly = “:real list” + +(* Evaluation of a polynomial *) +Definition evalPoly_def: + evalPoly [] x = 0:real ∧ + evalPoly (c::cs) x = c + (x * evalPoly cs x) +End + +(* Normalization; remove trailing zeroes *) +Definition reduce_def: + reduce []:poly = [] ∧ + reduce (c::cs) = + (let normalCs = reduce cs in + if normalCs = [] then + if c = 0 then [] else [c] + else c::normalCs) +End + +(* Smart constructors for constants and variables *) +Definition cst_def: + cst (c:real):poly = if c = 0 then [] else [c] +End + +Definition var_def: + var (0:num):poly = [1] ∧ + var (SUC n) = 0::(var n) +End + +(** monomial function, shifts polynomial p by n steps by preprending 0's *) +Definition monom_def: + monom (0:num) (p:poly) = p ∧ + monom (SUC d:num) (p:poly) = [&0] ++ (monom d p) +End + +Definition coeff_def: + coeff (p:poly) n = + case oEL n p of + | NONE => 0:real + | SOME x => x +End + +(* Negation, Addition, Subtraction, Multiplication with constants, +polynomial multiplication *) +Definition poly_add_aux_def: + poly_add_aux [] p2:poly = p2 ∧ + poly_add_aux (c1::cs1) p2 = + case p2 of + | [] => (c1::cs1) + | (c2::cs2) => (c1+c2):: poly_add_aux cs1 cs2 +End + +Definition poly_add_def: + poly_add p1 p2 = reduce (poly_add_aux p1 p2) +End + +Definition poly_mul_cst_aux_def[nocompute]: + poly_mul_cst_aux c []:poly = [] ∧ + poly_mul_cst_aux c (c1::cs) = (c * c1) :: poly_mul_cst_aux c cs +End + +Theorem poly_mul_cst_aux_comp[compute]: + poly_mul_cst_aux c p = + (if p = [] then [] else + let hdP = HD p; newC = c * hdP in newC :: poly_mul_cst_aux c (TL p)) +Proof + Induct_on ‘p’ >> gs[poly_mul_cst_aux_def] +QED + +Definition poly_mul_cst_def[nocompute]: + poly_mul_cst c p = reduce (poly_mul_cst_aux c p) +End + +Theorem poly_mul_cst_comp[compute]: + poly_mul_cst c p = + let cmul_p = poly_mul_cst_aux c p in reduce cmul_p +Proof + gs[poly_mul_cst_def] +QED + +Definition poly_neg_def: + poly_neg p = poly_mul_cst (-1) p +End + +Definition poly_sub_def[nocompute]: + poly_sub p1 p2 = poly_add p1 (poly_neg p2) +End + +Theorem poly_sub_comp[compute]: + poly_sub p1 p2 = + let p2_neg = poly_mul_cst (-1) p2 in poly_add p1 p2_neg +Proof + gs[poly_sub_def, poly_neg_def] +QED + +Definition poly_mul_def[nocompute]: + poly_mul [] p2 = [] ∧ + poly_mul (c1::cs1) p2 = + poly_add (poly_mul_cst c1 p2) (if cs1 = [] then [] else 0::(poly_mul cs1 p2)) +End + +Theorem poly_mul_comp[compute]: + poly_mul p1 p2 = + if p1 = [] then [] else + let hd_p1 = HD p1; + mul_cst1 = poly_mul_cst hd_p1 p2; + remain = if TL p1 = [] then [] else let rec = (poly_mul (TL p1) p2) in 0::rec + in + poly_add mul_cst1 remain +Proof + Induct_on ‘p1’ >> gs[poly_mul_def] +QED + +Definition poly_pow_def: + poly_pow p 0 = [1]:poly ∧ + poly_pow p (SUC n) = poly_mul p (poly_pow p n) +End + +Definition derive_aux_def[nocompute]: + derive_aux n ([]:poly) = [] ∧ + derive_aux n (c::cs) = (&n * c) :: derive_aux (SUC n) cs +End + +Theorem derive_aux_comp[compute]: + derive_aux n p = + if p = [] then [] + else let hd_elem = HD p; + hd_deriv = &n * hd_elem; + rec_res = derive_aux (SUC n) (TL p) + in + hd_deriv :: rec_res +Proof + Induct_on ‘p’ >> gs[derive_aux_def] +QED + +Definition derive_def: + derive (l:poly) = reduce (if l = [] then [] else derive_aux 1 (TL l)) +End + +Definition deg_def: + deg(p:poly) = LENGTH (reduce p) - 1 +End + +val _ = map Parse.overload_on [ + ("--p", Term ‘poly_neg’), + ("+p", Term ‘poly_add’), + ("-p", Term ‘poly_sub’), + ("*p", Term ‘poly_mul’), + ("*c", Term ‘poly_mul_cst’), + ("**p", Term ‘poly_pow’) + ] + +val _ = map (uncurry set_fixity) + [ ("+p", Infix(NONASSOC, 461)), + ("-p", Infix(NONASSOC, 461)), + ("*p", Infix(NONASSOC, 470)), + ("*c", Infix(NONASSOC, 470)), + ("**p",Infix(NONASSOC, 471)) + ] + +Definition zerop_def: + zerop (p:poly) = (reduce p = []) +End + +Theorem reduce_preserving: + ∀ p. + evalPoly (reduce p) = evalPoly p +Proof + Induct_on ‘p’ >> gs[reduce_def, FUN_EQ_THM] + >> rpt strip_tac >> gs[evalPoly_def] + >> rename1 ‘c1 :: reduce cs’ + >> ntac 2 (cond_cases_tac >> gs[evalPoly_def]) +QED + +Theorem cst_reduced: + ∀ c. reduce (cst c) = cst c +Proof + rpt strip_tac >> gs[cst_def] >> cond_cases_tac >> gs[reduce_def] +QED + +Theorem var_not_empty: + ∀ n. var n ≠ [] +Proof + strip_tac >> Cases_on ‘n’ >> gs[var_def] +QED + +Theorem var_reduced: + ∀ n. + reduce (var n) = var n +Proof + Induct_on ‘n’ >> gs[var_def, reduce_def, var_not_empty] +QED + +Theorem reduce_idempotent: + ∀ p. + reduce (reduce p) = reduce p +Proof + Induct_on ‘p’ >> gs[reduce_def] + >> rpt strip_tac >> cond_cases_tac + >- (cond_cases_tac >> gs[reduce_def]) + >> gs[reduce_def] +QED + +Theorem poly_add_reduced: + ∀ p1 p2. + reduce (p1 +p p2) = p1 +p p2 +Proof + gs[poly_add_def, reduce_idempotent] +QED + +Theorem poly_mul_cst_reduced: + ∀ c p. + reduce (c *c p) = c *c p +Proof + gs[poly_mul_cst_def, reduce_idempotent] +QED + +Theorem poly_neg_reduced: + ∀ p. + reduce (--p p) = --p p +Proof + gs[poly_neg_def, poly_mul_cst_reduced] +QED + +Theorem poly_mul_reduced: + ∀ p1 p2. + reduce (p1 *p p2) = p1 *p p2 +Proof + Induct_on ‘p1’ >> gs[reduce_def, poly_mul_def, poly_add_reduced] +QED + +Theorem poly_pow_reduced: + ∀ p n. + reduce (p **p n) = p **p n +Proof + Induct_on ‘n’ >> gs[reduce_def, poly_pow_def, poly_mul_reduced] +QED + +(* Relate to univariate HOL4 functions *) +Definition polyEvalsTo_def: + polyEvalsTo (p:poly) x (r:real) ⇔ + evalPoly p x = r +End + +Theorem polyEvalsTo_Var: + ∀ x. + polyEvalsTo (var n) x (x pow n) +Proof + Induct_on ‘n’ >> gs[polyEvalsTo_def, evalPoly_def, var_def, pow] +QED + +Theorem polyEvalsTo_Const: + ∀ c x. + polyEvalsTo (cst c) x c +Proof + rpt strip_tac >> gs[polyEvalsTo_def, cst_def] + >> cond_cases_tac >> gs[evalPoly_def] +QED + +Theorem polyEvalsTo_MulCst: + ∀ p1 r1 c x. + polyEvalsTo p1 x r1 ⇒ + polyEvalsTo (c *c p1) x (c * r1) +Proof + Induct_on ‘p1’ + >> gs[polyEvalsTo_def, evalPoly_def, poly_mul_cst_def, reduce_preserving, + poly_mul_cst_aux_def] + >> rpt strip_tac >> pop_assum kall_tac >> real_tac +QED + +Theorem polyEvalsTo_Neg: + ∀ p1 x r1. + polyEvalsTo p1 x r1 ⇒ + polyEvalsTo (--p p1) x (- r1) +Proof + rpt strip_tac >> pop_assum $ mp_then Any assume_tac polyEvalsTo_MulCst + >> pop_assum $ qspec_then ‘-1’ assume_tac >> gs[poly_neg_def] + >> real_tac +QED + +Theorem polyEvalsTo_Add: + ∀ p1 r1 p2 r2 x. + polyEvalsTo p1 x r1 ⇒ + polyEvalsTo p2 x r2 ⇒ + polyEvalsTo (p1 +p p2) x (r1 + r2) +Proof + Induct_on ‘p1’ >> rpt strip_tac + >> gs[polyEvalsTo_def, evalPoly_def, poly_add_def, reduce_preserving, + poly_add_aux_def] + >> top_case_tac >> pop_assum $ rewrite_tac o single o GSYM + >> gs[evalPoly_def] + >> pop_assum $ rewrite_tac o single o GSYM + >> pop_assum kall_tac + >> real_tac +QED + +Theorem polyEvalsTo_Sub: + ∀ p1 r1 p2 r2 x. + polyEvalsTo p1 x r1 ⇒ + polyEvalsTo p2 x r2 ⇒ + polyEvalsTo (p1 -p p2) x (r1 - r2) +Proof + rpt strip_tac + >> gs[poly_sub_def] + >> pop_assum $ mp_then Any mp_tac polyEvalsTo_Neg + >> pop_assum $ mp_then Any mp_tac polyEvalsTo_Add + >> rpt strip_tac >> res_tac >> real_tac +QED + +Theorem poly_add_aux_lid: + poly_add_aux p [ ] = p ∧ + poly_add_aux p [0] = (if p = [] then [0] else p) +Proof + Induct_on ‘p’ + >> rpt strip_tac + >> gs[poly_add_aux_def] +QED + +Theorem poly_add_lid: + p +p [ ] = reduce p ∧ + p +p [0] = reduce p +Proof + Induct_on ‘p’ + >> rpt strip_tac + >> gs[poly_add_def, poly_add_aux_def, reduce_def, poly_add_aux_lid] +QED + +Theorem polyEvalsTo_cons: + x ≠ 0 ∧ + polyEvalsTo (c1::cs) x r ⇒ + polyEvalsTo cs x ((r - c1) / x) +Proof + gs[polyEvalsTo_def, evalPoly_def] >> rpt strip_tac + >> pop_assum $ gs o single o GSYM >> gs[real_div] >> real_tac +QED + +Theorem polyEvalsTo_cons_zero: + polyEvalsTo cs x r ⇒ + polyEvalsTo (0::cs) x (r * x) +Proof + gs[polyEvalsTo_def, evalPoly_def] +QED + +Theorem polyEvalsTo_Mul: + ∀ p1 r1 p2 r2 x. + polyEvalsTo p1 x r1 ⇒ + polyEvalsTo p2 x r2 ⇒ + polyEvalsTo (p1 *p p2) x (r1 * r2) +Proof + Induct_on ‘p1’ >> rpt strip_tac + >- gs[polyEvalsTo_def, evalPoly_def, poly_mul_def] + >> ‘polyEvalsTo (h *c p2) x (h * r2)’ + by (irule polyEvalsTo_MulCst >> gs[]) + >> gs[poly_mul_def] + >> first_assum $ mp_then Any mp_tac polyEvalsTo_Add + >> cond_cases_tac + >- gs[poly_add_lid, polyEvalsTo_def, evalPoly_def, poly_mul_cst_def, reduce_preserving] + >> disch_then $ qspecl_then [‘0::(p1 *p p2)’] mp_tac + >> Cases_on ‘x = 0’ + >- ( + gs[] >> disch_then $ qspec_then ‘0’ mp_tac + >> impl_tac >> gs[polyEvalsTo_def, evalPoly_def]) + >> last_x_assum $ mp_then Any mp_tac polyEvalsTo_cons >> impl_tac >> gs[] + >> disch_then (fn thm => last_x_assum (fn ithm => mp_then Any mp_tac ithm thm)) + >> disch_then (fn ithm => last_x_assum (fn thm => mp_then Any mp_tac ithm thm)) + >> strip_tac + >> pop_assum $ mp_then Any assume_tac polyEvalsTo_cons_zero + >> disch_then drule >> strip_tac + >> gs[polyEvalsTo_def] >> real_tac +QED + +Theorem polyEvalsTo_Pow: + ∀ p n r x. + polyEvalsTo p x r ⇒ + polyEvalsTo (p **p n) x (r pow n) +Proof + Induct_on ‘n’ + >- gs[polyEvalsTo_def, evalPoly_def, poly_pow_def] + >> rpt strip_tac >> res_tac + >> last_x_assum $ mp_then Any mp_tac polyEvalsTo_Mul + >> disch_then drule >> gs[poly_pow_def, pow] +QED + +Theorem deep_embedding: +(∀ x. polyEvalsTo p x r) ⇒ +∀ x. evalPoly p x = (λ x:real. r) x +Proof + rpt strip_tac >> gs[polyEvalsTo_def] +QED + +(** Connecting the semantics of HOL4 and realPoly **) +Theorem reduce_normalize_compat: + reduce p = normalize p +Proof + Induct_on ‘p’ + >- gs[reduce_def, normalize] + >> rpt strip_tac >> gs[reduce_def, normalize] +QED + +Theorem deg_degree: + deg p = degree p +Proof + gs[deg_def, degree, PRE_SUB1, reduce_normalize_compat] +QED + +Theorem poly_compat: + ∀p x. evalPoly p x = poly p x +Proof + Induct_on ‘p’ + >- gs[evalPoly_def, poly_def] + >> rpt strip_tac + >> gs[evalPoly_def, poly_def] +QED + +Definition compose_def: + compose [] p = [] ∧ + compose (c::cs) p = [c] +p (p *p (compose cs p)) +End + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/realZeroLib.sml b/floatingPoint/tools/dandelion/realZeroLib.sml new file mode 100644 index 0000000000..b4eb458603 --- /dev/null +++ b/floatingPoint/tools/dandelion/realZeroLib.sml @@ -0,0 +1,580 @@ +(** + Library implementing the automatic computations + done by Dandelion +**) +structure realZeroLib = +struct + open RealArith realTheory realLib realSyntax polyTheory; + open realPolyTheory realPolyProofsTheory checkerTheory moreRealTheory + sturmComputeTheory transcLangTheory transcIntvSemTheory approxPolyTheory + transcApproxSemTheory transcReflectTheory euclidDivTheory; + open bossLib preambleDandelion; + + exception ZeroLibErr of string; + + val useBinary = ref false; + val createMetiTarskiQuery = ref false; + val createCoqIntervalQuery = ref false; + val createSOSFile = ref false; + + val _ = computeLib.add_thms [REAL_INV_1OVER] computeLib.the_compset; + val _ = computeLib.add_funs [polyTheory.poly_diff_def, polyTheory.poly_diff_aux_def, polyTheory.poly_def] + (* val _ = bitArithLib.use_karatsuba(); *) + + fun appOrErr (P:term -> bool) (f:term -> 'a) (t:term) (errMsg:string) :'a = + if P t then f t else raise ZeroLibErr errMsg; + + fun extractDom (t:term) (var:term) : term * term = + let + val (lhsCond, rhsCond) = appOrErr is_conj dest_conj t "Precondition not a conjunction" + val (lhs1, rhs1) = appOrErr realSyntax.is_leq realSyntax.dest_leq lhsCond "Precondition must be a conjunction of <= statements" + val (lhs2, rhs2) = appOrErr realSyntax.is_leq realSyntax.dest_leq rhsCond "Precondition must be a conjunction of <= statements" + val (var1, cnst1, isUb) = if is_var lhs1 then (lhs1, rhs1, true) + else if is_var rhs1 then (rhs1, lhs1, false) + else raise ZeroLibErr "No variable in lhs of precondition" + val (var2, cnst2) = if is_var lhs2 then (lhs2, rhs2) + else if is_var rhs2 then (rhs2, lhs2) else raise ZeroLibErr "No variable in rhs of precondition" + val cnst1Eval = EVAL cnst1 |> concl |> rhs + val cnst2Eval = EVAL cnst2 |> concl |> rhs + val _ = if term_eq var1 var2 andalso term_eq var2 var then () + else raise ZeroLibErr "Precondition does not depend only on universally quantified variable" + in + if isUb then (cnst2Eval, cnst1Eval) else (cnst1Eval, cnst2Eval) + end; + + fun arbint2String (i:Arbint.int) = + let val strList = explode o Arbint.toString $ i + in + implode (List.take (strList, (FixedInt.- (List.length strList, 1)))) + end; + + fun cst2String (t:term) = + if realSyntax.is_div t then (* Term is a fractional constant *) + let + val (nom, denom) = realSyntax.dest_div t + val nomI = appOrErr realSyntax.is_real_literal realSyntax.int_of_term nom "Invalid constant" + val denomI = appOrErr realSyntax.is_real_literal realSyntax.int_of_term denom "Invalid constant" + in + arbint2String nomI ^ "/" ^ arbint2String denomI + end + else arbint2String (appOrErr realSyntax.is_real_literal realSyntax.int_of_term t "Invalid constant") + + fun var2String (t:term) = + if realSyntax.is_pow t then + let val (var, pow) = realSyntax.dest_pow t + in + var2String var ^"^"^Arbnum.toString (appOrErr numSyntax.is_numeral numSyntax.dest_numeral pow "Invalid power") + end + else fst (appOrErr is_var dest_var t ("Not a variable "^term_to_string t)); + + fun mul2String (t:term) = + let val (var, cst) = appOrErr realSyntax.is_mult realSyntax.dest_mult t "Not a multiplication" + in + var2String var ^ " * " ^ cst2String cst + end; + + fun poly2String (t:term) = + if realSyntax.is_plus t then (* Recursion case *) + let + val (lhs, rhs) = appOrErr realSyntax.is_plus realSyntax.dest_plus t "Translation error" + val lhsStr = + if realSyntax.is_mult lhs then (* The lhs is a multiplication of var with cst *) + mul2String lhs + else (* The lhs is a constant *) + cst2String lhs + in + "( " ^ lhsStr ^ " ) + ( " ^ poly2String rhs ^ " )" + end + else if realSyntax.is_mult t then mul2String t + else var2String t; + + infix @^; + fun x @^ y = x ^ "\n" ^ y; + + fun poly2Sollya (poly:string) (dom:string) : string = + "oldDisplay=display;" @^ + "display = powers!; //putting ! after a command supresses its output" @^ + "diam = 1b-200!;" @^ + "p = "^ poly ^";" @^ + "zeros = findzeros(p, "^ dom ^ ");" @^ + "for t in zeros do {" @^ + " print (\" (\", mantissa (inf(t)), \" * inv (2 pow\", -exponent(inf(t)), \"),\");" @^ + " print (\" \", mantissa (sup(t)), \" * inv (2 pow\", -exponent(sup(t)), \"));\");" @^ + "};"; + + (** Compute the number of zeros of polynomial diffP on domain dom **) + fun STURM_SEQ_CONV (diffP:term) (dom:term) = + let + val _ = if not (type_of diffP = “:poly”) orelse not (type_of dom = “:real#real”) + then raise ZeroLibErr "STURM_SEQ_CONV needs polynomial inputs" else () + val diffP2 = Parse.Term ‘diff ^diffP’ |> EVAL + val _ = print "Starting Sturm Sequence computation\n" + val sseq_aux = decls "sturm_seq_aux"; + (* val _ = computeLib.monitoring := SOME (same_const (hd sseq_aux)) *) + val sseqOpt = Parse.Term ‘sturm_seq ^diffP (diff ^diffP)’ |> EVAL + val sseq = appOrErr optionSyntax.is_some optionSyntax.dest_some (sseqOpt |> concl |> rhs) "Sturm sequence computation failed" + val th = MATCH_MP sturm_seq_equiv sseqOpt + val zeroList = Parse.Term ‘numZeros ^diffP (diff ^diffP) ^dom ^sseq’ |> EVAL + val (res, numZeros) = zeroList |> concl |> rhs |> pairSyntax.dest_pair + val _ = if Term.compare (res, “Valid”) = EQUAL then () else raise ZeroLibErr "Failed to computed number of zeros" + val zerosThm = MATCH_MP (MATCH_MP (REWRITE_RULE [GSYM AND_IMP_INTRO] numZeros_sound) sseqOpt) zeroList |> SIMP_RULE std_ss [] + val iv_valid = zerosThm |> concl |> dest_imp |> fst + val iv_validThm = Q.prove (‘^iv_valid’, gs[]); + val zerosThmFull = MATCH_MP zerosThm iv_validThm + val _ = save_thm ("zerosThmFull", zerosThmFull) + in + (print "Finished sturm sequence computations\n"; (zerosThmFull, numZeros)) + end; + + fun getZerosFromSollya polyDiff var lb ub = let + val polyAsReal = Parse.Term ‘evalPoly ^polyDiff ^var’ + |> REWRITE_CONV [evalPoly_def] + |> SIMP_RULE std_ss [REAL_LDISTRIB, REAL_MUL_LZERO, + REAL_MUL_RZERO, REAL_ADD_LID, + REAL_MUL_ASSOC, REAL_ADD_RID, + pow_simp] + |> rhs o concl + val polyAsString = poly2String polyAsReal + val sollyaInput = poly2Sollya polyAsString ("[" ^ cst2String lb ^"; " ^ cst2String ub ^"]") + val fileStr = TextIO.openOut ("/tmp/sollya_input_"^Theory.current_theory()^".sollya") + val _ = (TextIO.output (fileStr, sollyaInput); TextIO.closeOut fileStr) + val sollyaPath = "FILLED_IN_BY_HOLPREEXEC" + (* case Process.getEnv "CAKEMLDIR" of + SOME p => p ^ "/floatingPoint/tools/Dandelion/sollya-8.0/sollya" + | NONE => + (let val (instr, outstr) = Unix.streamsOf(Unix.execute("/usr/bin/which", ["sollya"])) + in TextIO.inputAll(instr) |> explode |> List.rev |> tl |> List.rev |> implode end) + handle SysErr _ => (print "Could not get path for Sollya\n"; ""); *) + val (instr, outStr) = + (Unix.streamsOf(Unix.execute(sollyaPath, ["--warnonstderr", + "/tmp/sollya_input_"^Theory.current_theory()^".sollya"]))) + handle SysErr _ => (print ("Could not run Sollya at "^sollyaPath ^ "\n"); raise ZeroLibErr "") + (*val (instr, outStr) = + (*Unix.streamsOf(Unix.execute("/home/hbecker/Programs/sollya-7.0/sollya", ["--warnonstderr", "/tmp/sollya_input.sollya"])) *) + Unix.streamsOf(Unix.execute("sollya", ["--warnonstderr", "/tmp/sollya_input.sollya"])) *) + in + "[" ^ TextIO.inputAll(instr) ^ "]:(real#real) list" + end; + + fun var2HOLlightString (t:term) = + if realSyntax.is_pow t then + let val (var, pow) = realSyntax.dest_pow t + in + var2String var ^" pow " ^ Arbnum.toString (appOrErr numSyntax.is_numeral numSyntax.dest_numeral pow "Invalid power") + end + else fst (appOrErr is_var dest_var t ("Not a variable "^term_to_string t)); + + fun mul2HOLlightString (t:term) = + let val (var, cst) = appOrErr realSyntax.is_mult realSyntax.dest_mult t "Not a multiplication" + in + var2HOLlightString var ^ " * (&" ^ cst2String cst ^ ")" + end; + + fun poly2HOLlightString (t:term) = + if realSyntax.is_plus t then (* Recursion case *) + let + val (lhs, rhs) = appOrErr realSyntax.is_plus realSyntax.dest_plus t "Translation error" + val lhsStr = + if realSyntax.is_mult lhs then (* The lhs is a multiplication of var with cst *) + mul2HOLlightString lhs + else (* The lhs is a constant *) + "(&" ^ cst2String lhs ^")" + in + "( " ^ lhsStr ^ " ) + ( " ^ poly2HOLlightString rhs ^ " )" + end + else if realSyntax.is_mult t then mul2HOLlightString t + else var2HOLlightString t; + + (** Produces a HOL-light input that calls into REAL_SOS_CONV **) + fun to_SOS_tm (t:term) = let + val (var, imp) = appOrErr is_forall dest_forall t "Input term not universally quantified" + val (pre, conc) = appOrErr is_imp dest_imp imp "Input term not of the form ! x. _ ==> _" + val (lb, ub) = extractDom pre var + val (polyAppAbs, eps) = appOrErr realSyntax.is_leq realSyntax.dest_leq conc "Input term not of the form ! x. pre ==> _ <= _" + val realEps = EVAL eps |> rhs o concl + val polyApp = rand polyAppAbs + val (poly, var) = strip_comb polyApp |> snd |> (fn ts => (hd ts, hd (tl ts))) + val polyAsReal = Parse.Term ‘evalPoly ^poly ^var’ + |> EVAL + |> SIMP_RULE std_ss [REAL_LDISTRIB, REAL_MUL_LZERO, + REAL_MUL_RZERO, REAL_ADD_LID, + REAL_MUL_ASSOC, REAL_ADD_RID, + pow_simp] + |> rhs o concl + val polyAsString = poly2HOLlightString polyAsReal + val varStr = var2HOLlightString var + val holStr = "! " ^ varStr ^ ". " ^ + "(&" ^ cst2String lb ^ "):real <= " ^ varStr ^ " /\\ " ^ + varStr ^ " <= (&" ^ cst2String ub ^ "):real ==> " ^ + "( " ^ polyAsString ^ "):real <= (&" ^ cst2String realEps ^ "):real" + in + "#use \"hol.ml\";;\n#use \"Examples/sos.ml\";;\ntime PURE_SOS `" ^ holStr ^ "`;;" + end; + + fun writeSOSFile (t:term) = let + val tStr = to_SOS_tm t + val fileStr = TextIO.openOut ("./" ^ Theory.current_theory() ^ ".ml") + in + (TextIO.output (fileStr, tStr); TextIO.closeOut fileStr) + end; + + (** Takes as input a term of the form ! x. x IN ... ==> poly p x <= eps and + checks it by using the Sollya tool to infer zeros **) + fun REAL_ZERO_CONV (t:term) = + let + val _ = if (!createSOSFile) then writeSOSFile t else () + val (var, imp) = appOrErr is_forall dest_forall t "Input term not universally quantified" + val (pre, conc) = appOrErr is_imp dest_imp imp "Input term not of the form ! x. _ ==> _" + val (lb, ub) = extractDom pre var + val dom = Parse.Term ‘(^lb, ^ub)’ + val (polyAppAbs, eps) = appOrErr realSyntax.is_leq realSyntax.dest_leq conc "Input term not of the form ! x. pre ==> _ <= _" + val polyApp = rand polyAppAbs + val (poly, var) = strip_comb polyApp |> snd |> (fn ts => (hd ts, hd (tl ts))) + val polyDiff = Parse.Term ‘diff ^poly’ |> EVAL + val (zerosThm, numZeros) = STURM_SEQ_CONV (polyDiff |> concl |> rhs) dom + val _ = print "Getting zeros from Sollya\n" + val res = getZerosFromSollya (polyDiff |> rhs o concl) var lb ub + val _ = print "Got zeros from Sollya\n" + val zeroList = Parse.Term [QUOTE res] + val zeros = numSyntax.dest_numeral numZeros |> Arbnum.toInt + in + if zeros <= 0 then raise ZeroLibErr "Need to check for at least one zero" + else + let + val _ = print ("Starting zero validation\n"); + val validationThm = + Parse.Term ‘validateZerosLeqErr ^poly ^dom ^zeroList ^eps ^numZeros’ + |> EVAL + val _ = save_thm ("validationThm", validationThm) + val _ = if Term.compare (rhs o concl $ validationThm |> pairSyntax.dest_pair |> fst, “Valid”) = EQUAL then () + else raise ZeroLibErr "Failed to prove validity of zeros found by Sollya" + val _ = print ("Finished zero validation\n"); + val resThm = (MATCH_MP (REWRITE_RULE [GSYM AND_IMP_INTRO] validateZerosLeqErr_sound) (GSYM polyDiff)) + |> Q.SPEC ‘(^lb, ^ub)’ |> SIMP_RULE std_ss [] + |> (fn th => MATCH_MP th zerosThm) + |> (fn th => MATCH_MP th validationThm) + |> REWRITE_RULE [AND_IMP_INTRO] + in + resThm + end + end; + + val var1_thm = EVAL “var 1”; + + fun is_real_const (t:term) = + is_real_literal t orelse + (realSyntax.is_div t andalso + (let val (t1, t2) = realSyntax.dest_div t in (is_real_literal t1 andalso is_real_literal t2) end)) + + (** Assumes: vars t = [x] and type_of t = “:real” **) + fun reflect (t:term) (x:term) : thm * thm = + if is_real_const t then + let val pEqThm = EVAL o Parse.Term $ ‘cst ^t’ in + (Q.SPECL [‘^t’, ‘^x’] polyEvalsTo_Const + |> REWRITE_RULE [pEqThm] + |> CONV_RULE $ RATOR_CONV $ RATOR_CONV $ RAND_CONV EVAL, + pEqThm) + end + else if is_var t then + let val pEqThm = var1_thm in + (Q.SPECL [‘1’, ‘^t’] (GEN “n:num” polyEvalsTo_Var) + |> REWRITE_RULE [var1_thm, POW_1] + |> CONV_RULE $ RATOR_CONV $ RATOR_CONV $ RAND_CONV EVAL, + pEqThm) + end + else if realSyntax.is_plus t then + let + val (t1, t2) = realSyntax.dest_plus t + val (thm1, p1) = reflect t1 x + val (thm2, p2) = reflect t2 x + val pEqThm = EVAL o Parse.Term $ ‘^(p1 |> concl |> rhs) +p ^(p2 |> concl |> rhs)’ + in + (MATCH_MP (MATCH_MP polyEvalsTo_Add thm1) thm2 + |> REWRITE_RULE [pEqThm] + |> CONV_RULE $ RATOR_CONV $ RATOR_CONV $ RAND_CONV EVAL, + pEqThm) + end + else if realSyntax.is_minus t then + let + val (t1, t2) = realSyntax.dest_minus t + val (thm1, p1) = reflect t1 x + val (thm2, p2) = reflect t2 x + val pEqThm = EVAL o Parse.Term $ ‘^(p1 |> concl |> rhs) +p ^(p2 |> concl |> rhs)’ + in + (MATCH_MP (MATCH_MP polyEvalsTo_Sub thm1) thm2 + |> REWRITE_RULE [pEqThm] + |> CONV_RULE $ RATOR_CONV $ RATOR_CONV $ RAND_CONV EVAL, + pEqThm) + end + else if realSyntax.is_mult t then + let + val (t1, t2) = realSyntax.dest_mult t + val (thm1, p1) = reflect t1 x + val (thm2, p2) = reflect t2 x + val pEqThm = EVAL o Parse.Term $ ‘^(p1 |> concl |> rhs) *p ^(p2 |> concl |> rhs)’ + in + (MATCH_MP (MATCH_MP polyEvalsTo_Mul thm1) thm2 + |> REWRITE_RULE [pEqThm] + |> CONV_RULE $ RATOR_CONV $ RATOR_CONV $ RAND_CONV EVAL, + pEqThm) + end + else if realSyntax.is_negated t then + let + val t1 = realSyntax.dest_negated t + val (thm1, p1) = reflect t1 x + val pEqThm = EVAL o Parse.Term $ ‘--p ^(p1 |> concl |> rhs)’ + in + (MATCH_MP polyEvalsTo_Neg thm1 + |> REWRITE_RULE [pEqThm] + |> CONV_RULE $ RATOR_CONV $ RATOR_CONV $ RAND_CONV EVAL, + pEqThm) + end + else raise ZeroLibErr "Unsupported term"; + + fun findOrErr (P:'a -> bool) (xs:'a list):'a = + case List.find P xs of + NONE => raise ZeroLibErr "No element found" + | SOME a => a + + fun destCert (record:term):(term * term * term * term) = + let val (comps:(string * term) list) = snd $ TypeBase.dest_record record + in + (snd $ findOrErr (fn (x,y) => x = "transc") comps, + snd $ findOrErr (fn (x,y) => x = "poly") comps, + snd $ findOrErr (fn (x,y) => x = "eps") comps, + snd $ findOrErr (fn (x,y) => x = "iv") comps) + end + + fun testSollya() = + let + val sollyaInput = + "oldDisplay=display;" @^ + "display = powers!; //putting ! after a command supresses its output" @^ + (* "diam = 1b-100!;" @^ *) + "p = x * 1’;" @^ + "zeros = findzeros(p, [0;10]);" @^ + "print (\" DONE \");" + val fileStr = TextIO.openOut ("/tmp/sollya_input.sollya") + val _ = (TextIO.output (fileStr, sollyaInput); TextIO.closeOut fileStr) + val _ = print "Testing sollya\n" + val sollyaPath = "FILLED_IN_BY_HOLPREEXEC" + (* case Process.getEnv "CAKEMLDIR" of + SOME p => p ^ "/floatingPoint/tools/Dandelion/sollya-8.0/sollya" + | NONE => + (let val (instr, outstr) = Unix.streamsOf(Unix.execute("/usr/bin/which", ["sollya"])) + in TextIO.inputAll(instr) |> explode |> List.rev |> tl |> List.rev |> implode end) + handle SysErr _ => (print "Could not get path for Sollya\n"; ""); *) + val (instr, outStr) = + (Unix.streamsOf(Unix.execute(sollyaPath, ["--warnonstderr", "/tmp/sollya_input.sollya"]))) + handle SysErr _ => (print ("Could not run Sollya at "^sollyaPath ^ "\n"); raise ZeroLibErr "") + val res = TextIO.inputAll(instr); + in + print res + end; + + fun cst2BinString (t:term) = + if realSyntax.is_div t then (* Term is a fractional constant *) + let + val (nom, denom) = realSyntax.dest_div t + val nomI = appOrErr realSyntax.is_real_literal realSyntax.int_of_term nom "Invalid constant" + val denomI = appOrErr realSyntax.is_real_literal realSyntax.int_of_term denom "Invalid constant" + in + arbint2String nomI ^ "/" ^ arbint2String denomI + end + else (arbint2String (appOrErr realSyntax.is_real_literal realSyntax.int_of_term t "Invalid constant")) ^ "/" ^ "1" + + fun poly2BinString (t:term) = + if not (listSyntax.is_list t) then + raise ZeroLibErr "Translation error" + else + let val (tms, _) = listSyntax.dest_list t in + "POLY" ^ (List.foldl (fn (t,s) => s ^ " " ^ cst2BinString t) "" tms) + end; + + fun zeros2BinString (t:term) = + if not (listSyntax.is_list t) then + raise ZeroLibErr "Translation error" + else + let val (tms, _) = listSyntax.dest_list t in + "ZEROS" ^ (List.foldl + (fn (t,s) => + let val (lb,ub) = pairSyntax.dest_pair t in + s ^ " " ^ cst2BinString lb ^ " " ^ cst2BinString ub end) "" tms) + end; + + val approxCfg = Parse.Term ‘<| steps := 16 |> ’; + + fun writeMetiTarskiQuery transc poly eps iv_lo iv_hi var = let + val polyAsString = Parse.Term ‘evalPoly ^poly X’ + |> EVAL + |> SIMP_RULE std_ss [REAL_LDISTRIB, REAL_MUL_LZERO, + REAL_MUL_RZERO, REAL_ADD_LID, + REAL_MUL_ASSOC, REAL_ADD_RID, + pow_simp] + |> rhs o concl + |> poly2String + val transcAsReal = Parse.Term ‘interp ^transc [^var, X]’ + |> EVAL + val transcAsString = term_to_string (optionSyntax.dest_some (transcAsReal |> rhs o concl)) + |> String.translate (fn x => if x = #"X" then "(X)" else implode [x]) + val eps_eval = ((REWRITE_CONV [REAL_INV_1OVER] eps) handle UNCHANGED => REFL eps) |> rhs o concl + |> (fn t => (EVAL t handle UNCHANGED => REFL t))|> rhs o concl + val polyDiffString1 = "(" ^ transcAsString ^ " - (" ^ polyAsString ^ ")" ^ ")" + val polyDiffString2 = "((" ^ polyAsString ^ ") - " ^ transcAsString ^ ")" + val text = + "fof(" ^ Theory.current_theory() ^ ", conjecture, ! [X] :((" ^ + "X : (= "^ cst2String iv_lo ^ ","^cst2String iv_hi^"=)) => (\n"^ + "(" ^ polyDiffString1 ^ " <= " ^ cst2String eps_eval ^ ") &\n\n" ^ + "(" ^ polyDiffString2 ^ " <= " ^ cst2String eps_eval ^ "))))." + val fileStr = TextIO.openOut ("./" ^ Theory.current_theory() ^ ".tptp") + in + (TextIO.output (fileStr, text); TextIO.closeOut fileStr) + end; + + fun writeCoqIntervalQuery transc poly eps iv_lo iv_hi var = let + val polyAsString = Parse.Term ‘evalPoly ^poly x’ + |> EVAL + |> SIMP_RULE std_ss [REAL_LDISTRIB, REAL_MUL_LZERO, + REAL_MUL_RZERO, REAL_ADD_LID, + REAL_MUL_ASSOC, REAL_ADD_RID] + |> rhs o concl + |> term_to_string + val transcAsReal = Parse.Term ‘interp ^transc [^var, x]’ + |> EVAL + val transcAsString = term_to_string (optionSyntax.dest_some (transcAsReal |> rhs o concl)) + |> String.translate (fn x => if x = #"x" then "(x)" else implode [x]) + val eps_eval = ((REWRITE_CONV [REAL_INV_1OVER] eps) handle UNCHANGED => REFL eps) |> rhs o concl + |> (fn t => (EVAL t handle UNCHANGED => REFL t))|> rhs o concl + val text = + "Require Import Interval.Tactic.\n"^ + "Require Import Reals.\n\n"^ + "Goal\n"^ + "forall (x:R),(("^ (cst2String iv_lo) ^ " <= x <= " ^ (cst2String iv_hi) ^ + ") ->\n" ^ + "Rabs (" ^ transcAsString ^ " - (" ^ polyAsString ^ "))\n\t<=\n\t" ^ + (cst2String eps_eval) ^ ")%R.\n"^ + "Proof.\nintros.\ntime interval with (i_bisect x, i_taylor x).\nQed." + val fileStr = TextIO.openOut ("./" ^ Theory.current_theory() ^ ".v") + in + (TextIO.output (fileStr, text); TextIO.closeOut fileStr) + end; + + fun validateCert (defTh:thm) numApprox = + let + fun eval t = Parse.Term t |> EVAL + fun getSome diag t = if optionSyntax.is_some t then optionSyntax.dest_some t else raise ZeroLibErr diag + (* extract components from certificate *) + val (transc, poly, eps, iv) = destCert (defTh |> concl |> rhs) + val ivTm = eval ‘if (LENGTH ^iv = 1) then SOME (SND (HD ^iv)) else NONE’ + |> rhs o concl |> getSome "Could not extract interval" + val var = eval ‘if (LENGTH ^iv = 1) then SOME (FST (HD ^iv)) else NONE’ + |> rhs o concl |> getSome "Could not extract variable" + val iv_FST = EVAL “FST ^ivTm” + val iv_SND = EVAL “SND ^ivTm” + val _ = if (!createMetiTarskiQuery) then writeMetiTarskiQuery transc poly eps (iv_FST |> rhs o concl) (iv_SND |> rhs o concl) var else () + val _ = if (!createCoqIntervalQuery) then writeCoqIntervalQuery transc poly eps (iv_FST |> rhs o concl) (iv_SND |> rhs o concl) var else () + val approxSideThm = eval ‘approxPolySideCond ^numApprox’ |> SIMP_RULE std_ss [EQ_CLAUSES] + val ivAnnotThm = eval ‘interpIntv ^transc ^iv’ + val ivAnnotTm = ivAnnotThm |> rhs o concl |> getSome "Could not compute interval bounds" + val ivSoundThm = MATCH_MP interpIntv_sound ivAnnotThm + (*val sqrtReplPassThm = eval ‘sqrtReplace ^ivAnnotTm’ + val sqrtReplPassTm = sqrtReplPassThm |> rhs o concl |> getSome "Sqrt replacement pass failed" + val ivAnnotSqrtReplThm = eval ‘interpIntv ^sqrtReplPassTm ^iv’ + val ivAnnotSqrtReplTm = ivAnnotThm |> rhs o concl |> getSome "Could not compute interval bounds" + val ivSoundSqrtReplThm = MATCH_MP interpIntv_sound ivAnnotThm *) + val approxThm = eval ‘approxTransc (^approxCfg with steps := ^numApprox) ^ivAnnotTm’ + val approxTm = approxThm |> rhs o concl |> getSome "Could not compute high-accuracy approximations" + val length1Thm = eval ‘LENGTH ^iv = 1’ |> REWRITE_RULE [EQ_CLAUSES] + val approxSoundThm = + MATCH_MP + (MATCH_MP + (MATCH_MP + (REWRITE_RULE [GSYM AND_IMP_INTRO] approxTransc_sound_single) + length1Thm) + ivSoundThm) + approxThm + |> SIMP_RULE std_ss [erase_def, getAnn_def] + val transpThm = eval ‘reflectToPoly (erase (^approxTm)) ^var’ + val transpTm = transpThm |> rhs o concl |> getSome "Could not reflect into a polynomial" + val reflectOkThm = MATCH_MP reflectSemEquiv transpThm |> REWRITE_RULE [erase_def] + val varEqThm = EVAL “FST (HD ^iv)” + val ivEqThm = EVAL “SND (HD ^iv)” + val approxSoundPolyThm = REWRITE_RULE [varEqThm, ivEqThm, reflectOkThm, optionGet_SOME, AND_IMP_INTRO] approxSoundThm + (** Get rid of sqrtReplace pass result in conclusion **) + (* val ivSoundSingleThm = MATCH_MP validIVAnnot_single ivSoundThm + (* First build a "concrete environment" *) + val cenv = ‘[^(varEqThm |> rhs o concl), x:real]’ + val evalOrigThm = ivSoundSingleThm |> Q.SPEC cenv |> CONV_RULE $ RATOR_CONV $ RAND_CONV $ RAND_CONV EVAL |> UNDISCH + val evalSqrtReplPassThm = + MATCH_MP + (MATCH_MP (REWRITE_RULE [GSYM AND_IMP_INTRO] sqrtReplace_sound) sqrtReplPassThm) + ivSoundThm |> SIMP_RULE std_ss[AND_IMP_INTRO] |> ONCE_REWRITE_RULE [CONJ_COMM] + |> REWRITE_RULE[GSYM AND_IMP_INTRO] |> SPEC_ALL |> GEN “cenv:(string#real)list” |> Q.SPEC cenv + |> UNDISCH *) + val transpGetThm = Q.ISPEC ‘^(transpThm |> lhs o concl)’ optionGet_def + |> SIMP_RULE std_ss [SimpR “$=”, transpThm] + val err = Parse.Term ‘getAnn ^approxTm’ |> EVAL |> concl |> rhs + val errorpThm = Parse.Term ‘^transpTm -p ^poly’ |> EVAL + val errorp = errorpThm |> rhs o concl + in + if !useBinary then + let val polyString = poly2BinString errorp + val errString = "ERR " ^ cst2BinString (EVAL “^eps - ^err” |> rhs o concl) + val lb = EVAL “FST ^ivTm” |> rhs o concl + val ub = EVAL “SND ^ivTm” |> rhs o concl + val IVstring = "IV " ^ cst2BinString lb ^ " " ^ cst2BinString ub + val zerosTm = Parse.Term [QUOTE (getZerosFromSollya (EVAL “diff ^errorp” |> rhs o concl) “x:real” lb ub)] |> EVAL |> rhs o concl + val zeros = zeros2BinString zerosTm + val inp = polyString ^ "\n" ^ errString ^ "\n" ^ IVstring ^ "\n" ^ zeros + (** FIXME: Absolute path **) + val fileStr = TextIO.openOut ("./" ^ Theory.current_theory() ^ ".txt") + val _ = (TextIO.output (fileStr, inp); TextIO.closeOut fileStr) + in + approxSoundPolyThm + end + else let + val polyErrThm = + (testSollya(); + REAL_ZERO_CONV (Parse.Term ‘! x. FST (^ivTm) <= x /\ x <= SND (^ivTm) ==> abs (evalPoly ^errorp x) <= ^eps - ^err’)) + val polyErrThm_simped = REWRITE_RULE [GSYM errorpThm, eval_simps, + GSYM poly_compat, Once $ GSYM transpGetThm, + Once $ GSYM iv_FST, transpThm, optionGet_SOME] polyErrThm + val final_thm = MATCH_MP (MATCH_MP REAL_ABS_TRIANGLE_PRE approxSoundPolyThm) polyErrThm_simped + in + (save_thm ("err_sound_thm", final_thm); final_thm) + end end; + + fun REAL_INEQ_CONV (t:term) = let + val (var, tm) = appOrErr is_forall dest_forall t "Not a universally quantified statement" + val (pre, conc) = appOrErr is_imp dest_imp tm "Input term not of the form ! x. _ ==> _" + val (ltm, rtm) = appOrErr realSyntax.is_leq realSyntax.dest_leq conc "Conclusion not a <= expression" + in + if not (type_of var = “:real”) then raise ZeroLibErr "Only real number expressions are supported" + else let + val isAbs = realSyntax.is_absval ltm + val argTm = if isAbs then rand ltm else ltm + val (evalThm, _) = reflect (Parse.Term ‘^argTm :real’) var + val evalRwThm = evalThm |> REWRITE_RULE [polyEvalsTo_def, poly_compat] + val theTerm = if isAbs then t else “∀ ^(var). ^pre ⇒ abs ^argTm ≤ ^rtm” + in + (REAL_ZERO_CONV (REWRITE_CONV [GSYM evalRwThm ] theTerm |> rhs o concl) + |> SPEC var + |> REWRITE_RULE [evalRwThm] + |> GEN_ALL, isAbs, ltm) + end end; + + fun REAL_INEQ_TAC (asl, g) = let + val (ineqThm, isAbs, ltm) = REAL_INEQ_CONV g in + if isAbs then (MATCH_ACCEPT_TAC ineqThm ORELSE realLib.REAL_ARITH_TAC) (asl,g) + else ((assume_tac ineqThm + >> rpt strip_tac >> irule REAL_LE_TRANS >> qexists_tac ‘abs ^ltm’ >> conj_tac >> gs[ABS_LE]) + ORELSE realLib.REAL_ARITH_TAC) (asl, g) + end; + +end; + (** Some tests **) +(** + reflect “x * x - 3 * x - 10:real” “x:real” + (* reflect “~ ((x + 1/2):real) * x” “x:real” *) + (* val t = REAL_ZERO_CONV “! x. 90 <= x /\ x <= 100 ==> evalPoly [1; 2/100; 3] x <= 100:real” *) + **) diff --git a/floatingPoint/tools/dandelion/renameScript.sml b/floatingPoint/tools/dandelion/renameScript.sml new file mode 100644 index 0000000000..c60f7ead9b --- /dev/null +++ b/floatingPoint/tools/dandelion/renameScript.sml @@ -0,0 +1,13 @@ +(** + renaming theory to unify naming of theorems +**) + +open preambleDandelion; + +val _ = new_theory "rename"; + +val _ = map save_thm [ + ("OPTION_MAP_def", OPTION_MAP_DEF) + ] + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/sinDeg3.tptp b/floatingPoint/tools/dandelion/sinDeg3.tptp new file mode 100644 index 0000000000..338b7c2c41 --- /dev/null +++ b/floatingPoint/tools/dandelion/sinDeg3.tptp @@ -0,0 +1,4 @@ +fof(sinDeg3, conjecture, ! [X] :((X : (= 858993459/8589934592,1=)) => ( +((sin (X) - (( -1499276771/2199023255552 ) + ( ( X * 541190871/536870912 ) + ( ( X^2 * -3581686363/137438953472 ) + ( X^3 * -1202115613/8589934592 ) ) ))) <= 946027/4294967296) & + +(((( -1499276771/2199023255552 ) + ( ( X * 541190871/536870912 ) + ( ( X^2 * -3581686363/137438953472 ) + ( X^3 * -1202115613/8589934592 ) ) )) - sin (X)) <= 946027/4294967296)))). \ No newline at end of file diff --git a/floatingPoint/tools/dandelion/sinDeg3.txt b/floatingPoint/tools/dandelion/sinDeg3.txt new file mode 100644 index 0000000000..0dfdb7f92f --- /dev/null +++ b/floatingPoint/tools/dandelion/sinDeg3.txt @@ -0,0 +1,4 @@ +POLY 1499276771/2199023255552 -4319959/536870912 3581686363/137438953472 -688620457/25769803776 0/1 1/120 0/1 -1/5040 0/1 1/362880 0/1 -1/39916800 0/1 1/6227020800 0/1 -1/1307674368000 +ERR 604050419466553/2742391916199936000 +IV 858993459/8589934592 1/1 +ZEROS 45100603395809055999873618326478972947596312523513/187072209578355573530071658587684226515959365500928 11275150848952263999968404581619743236899078130879/46768052394588893382517914646921056628989841375232 11275150848952263999968404581619743236899078130879/46768052394588893382517914646921056628989841375232 176174232014879124999506321587808488076548095795/730750818665451459101842416358141509827966271488 13242477693278492129485276730695977342267653870789/23384026197294446691258957323460528314494920687616 13242477693278492129485276730695977342267653870791/23384026197294446691258957323460528314494920687616 13242477693278492129485276730695977342267653870791/23384026197294446691258957323460528314494920687616 26484955386556984258970553461391954684535307741585/46768052394588893382517914646921056628989841375232 40943620288261898600289190366266876150482539140183/46768052394588893382517914646921056628989841375232 20471810144130949300144595183133438075241269570093/23384026197294446691258957323460528314494920687616 20471810144130949300144595183133438075241269570093/23384026197294446691258957323460528314494920687616 20471810144130949300144595183133438075241269570095/23384026197294446691258957323460528314494920687616 \ No newline at end of file diff --git a/floatingPoint/tools/dandelion/sinDeg3.v b/floatingPoint/tools/dandelion/sinDeg3.v new file mode 100644 index 0000000000..ad633ef83b --- /dev/null +++ b/floatingPoint/tools/dandelion/sinDeg3.v @@ -0,0 +1,15 @@ +Require Import Interval.Tactic. +Require Import Reals. + +Goal +forall (x:R),((858993459/8589934592 <= x <= 1) -> +Rabs (sin (x) - (-1499276771 / 2199023255552 + +(x * (541190871 / 536870912) + + (x * x * (-3581686363 / 137438953472) + + x * x * x * (-1202115613 / 8589934592))))) + <= + 946027/4294967296)%R. +Proof. +intros. +time interval with (i_bisect x, i_taylor x). +Qed. \ No newline at end of file diff --git a/floatingPoint/tools/dandelion/sinDeg3Script.sml b/floatingPoint/tools/dandelion/sinDeg3Script.sml new file mode 100644 index 0000000000..aa2b39e800 --- /dev/null +++ b/floatingPoint/tools/dandelion/sinDeg3Script.sml @@ -0,0 +1,30 @@ +(* + Simple approximation of sine of degree 3 +*) +(* open bitArithLib; *) + +(* val _ = bitArithLib.use_karatsuba(); *) + +open realZeroLib; + +val _ = new_theory "sinDeg3"; + +Definition sin_example_def: + sin_example = <| + transc := Fun Sin (Var "x") ; + poly := [ + -1499276771 * inv ( 2 pow 41 ); + 541190871 * inv ( 2 pow 29 ); + -3581686363 * inv ( 2 pow 37 ); + -1202115613 * inv ( 2 pow 33 ); + ]; + eps := 946027 * inv (2 pow 32 ); + iv := [ ("x", + ( 858993459 * inv (2 pow 33 ), + 1 * inv (2 pow 0 )))]; + |> +End + +Theorem checkerSucceeds = validateCert sin_example_def “8:num”; + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/sollya-8.0.tar.gz b/floatingPoint/tools/dandelion/sollya-8.0.tar.gz new file mode 100644 index 0000000000..826c49ff6b Binary files /dev/null and b/floatingPoint/tools/dandelion/sollya-8.0.tar.gz differ diff --git a/floatingPoint/tools/dandelion/sollya-8.0/README.md b/floatingPoint/tools/dandelion/sollya-8.0/README.md new file mode 100644 index 0000000000..c1a67bbb20 --- /dev/null +++ b/floatingPoint/tools/dandelion/sollya-8.0/README.md @@ -0,0 +1 @@ +Dependency to generate unverified guesses diff --git a/floatingPoint/tools/dandelion/sturmComputeScript.sml b/floatingPoint/tools/dandelion/sturmComputeScript.sml new file mode 100644 index 0000000000..b67cfc86cc --- /dev/null +++ b/floatingPoint/tools/dandelion/sturmComputeScript.sml @@ -0,0 +1,331 @@ +(** + Define a computable version of the sturm sequence and + prove its equivalence with the non-computable version + of John Harrison + **) +open pred_setTheory listTheory bossLib RealArith realTheory polyTheory; +open realPolyTheory sturmTheory realPolyProofsTheory euclidDivTheory; +open renameTheory; +open bitArithLib; +open preambleDandelion; + +val _ = new_theory "sturmCompute"; + +Definition sturm_seq_aux_def: + sturm_seq_aux (0:num) (p:poly) (q:poly) = + (if (rm p (inv (coeff q (deg q)) *c q) = [] ∧ ~ zerop q) + then SOME [] + else NONE) + ∧ + sturm_seq_aux (SUC d:num) p q = + (let g = (rm p (inv (coeff q (deg q)) *c q)) in + if g = [] ∧ ~ zerop q then SOME [] + else if zerop q ∨ LENGTH (reduce q) < 2 then NONE else + case sturm_seq_aux d q (--p g) of + | SOME ss => SOME (--p g::ss) + | _ => NONE) +End + +Definition sturm_seq_def: + sturm_seq (p:poly) (q:poly) : poly list option = + if zerop q ∨ deg p ≤ 1 then NONE + else + case sturm_seq_aux (deg p - 1) p q of + | NONE => NONE + | SOME sseq => + case oEL (PRE (LENGTH sseq)) sseq of + | SOME [x] => if x ≠ 0 then SOME sseq + else NONE + | _ => NONE +End + +(* a / b = c where c * b + r = a*) +(* b divides (a + k * r) ⇔ ∃ c. (a + k * r) = b * c *) +(* We say p2 divides p1 if ∃ q. p1 * q = p2 *) +Theorem poly_long_div_poly_divides: + ∀ p q. + ~ zerop q ∧ + deg q < deg p ∧ + reduce p = p ∧ + coeff q (deg q) = 1 ⇒ + q poly_divides (p +p (--p (rm p q))) +Proof + rpt strip_tac >> gs[poly_divides, FUN_EQ_THM, GSYM poly_compat] + >> Cases_on ‘divmod p q’ >> gs[rm_def] + >> drule divmod_coeff_1 + >> rpt $ disch_then drule + >> strip_tac + >- ( + gs[zerop_def, eval_simps] + >> ‘evalPoly r = evalPoly (reduce r)’ by gs[reduce_preserving] + >> pop_assum $ rewrite_tac o single >> gs[evalPoly_def] + >> qexists_tac ‘q'’ >> gs[poly_compat, POLY_MUL]) + >> qexists_tac ‘q'’ >> gs[eval_simps] >> gs[poly_compat, POLY_MUL] + >> real_tac +QED + +Theorem deg_p_not_0: + ∀p. deg p ≠ 0 ⇒ p ≠ [] +Proof + gen_tac + >> rpt strip_tac >> CCONTR_TAC + >> ‘deg p = 0’ suffices_by gs[] + >> VAR_EQ_TAC + >> gs[deg_def, reduce_def, LENGTH] +QED + +(** Theorem on Euclidean division **) +Theorem poly_const_2_mul: + ∀ p a b x. + poly (a ## poly_mul_cst_aux b p) x = + poly (poly_mul_cst_aux (a * b) p) x +Proof + Induct_on ‘p’ + >- ( rpt strip_tac >> gs[poly_mul_cst_aux_def, POLY_CMUL_CLAUSES] ) + >> rpt strip_tac >> gs[poly_mul_cst_aux_def, poly_cmul_def] + >> gs[REAL_MUL_ASSOC, poly_def] +QED + +Theorem poly_cst_one_mul: + ∀p x. poly (poly_mul_cst_aux 1 p) x = poly p x +Proof + Induct_on ‘p’ + >- ( gen_tac >> gs[poly_mul_cst_aux_def] ) + >> rpt strip_tac + >> gs[poly_mul_cst_aux_def, poly_def] +QED + +Theorem poly_one_mul: + ∀ p q. poly (p + 1 ## q) = poly (p + q) +Proof + gen_tac + >> Induct_on ‘q’ + >- gs[POLY_CMUL_CLAUSES] + >> gen_tac + >> gs[poly_cmul_def] >> gs[FUN_EQ_THM] >> gen_tac + >> gs[POLY_ADD, poly_def] +QED + +Theorem nonzero_coeff: + ~ zerop p ⇒ + coeff p (deg p) ≠ 0 +Proof + Induct_on ‘p’ >> gs[deg_def, coeff_def, zerop_def, oEL_def, reduce_def] + >> Cases_on ‘reduce p’ >> gs[] + >- ( + rpt strip_tac + >> Cases_on ‘h = 0’ >> gs[]) + >> ‘SUC (SUC (LENGTH t)) - 2 = LENGTH t’ by gs[] + >> pop_assum $ rewrite_tac o single >> gs[] +QED + +Theorem normalized_normal: + ~ zerop p ⇒ + coeff ((inv (coeff p (deg p))) *c p) (deg ((inv (coeff p (deg p))) *c p)) = 1 +Proof + Induct_on ‘p’ + >- gs[zerop_def, coeff_def, deg_def, oEL_def, reduce_def, poly_mul_cst_0] + >> rpt strip_tac + >> gs[coeff_cst_mul] + >> Cases_on ‘reduce p’ + >- ( + gs[deg_def, reduce_def, zerop_def] + >> ‘h ≠ 0’ by (Cases_on ‘h = 0’ >> gs[]) + >> ‘coeff (h::p) 0 = h’ by (gs[coeff_def, oEL_def]) + >> ‘inv h ≠ 0’ by (CCONTR_TAC >> gs[]) + >> gs o single $ SIMP_RULE std_ss [deg_def] deg_of_const_mul + >> gs[reduce_def, REAL_MUL_LINV]) + >> ‘0 < deg (h::p)’ by gs[deg_def, reduce_def] + >> gs[coeff_cons] + >> ‘~ zerop p’ by gs[zerop_def] + >> imp_res_tac nonzero_coeff + >> gs[deg_of_const_mul, coeff_cons] +QED + +Theorem nonzero_normalize: + ~ zerop p ⇒ + ~ zerop ((inv (coeff p (deg p))) *c p) +Proof + Induct_on ‘p’ + >- gs[zerop_def, reduce_def] + >> rpt strip_tac + >> Cases_on ‘reduce p = []’ + >- ( gs[zerop_def, reduce_def, coeff_def, poly_mul_cst_def, oEL_def, + poly_mul_cst_aux_def] + >> ‘deg (h :: p) = 0’ by + ( gs[deg_def, reduce_def] + >> cond_cases_tac >> gs[] + ) + >> gs[] + >> Cases_on ‘h=0’ + >- gs[] + >> gs[reduce_p_poly_mul_holds] + >> ‘h⁻¹ * h = &1 ’ by gs[REAL_MUL_LINV] + >> gs[reduce_def] + ) + >> ‘0 < deg (h::p)’ by gs[deg_def, reduce_def, length_gt_0] + >> ‘ coeff (h::p) (deg (h::p)) = coeff p (deg p)’ by gs[coeff_cons] + >> ‘¬zerop p’ by gs[zerop_def] + >> gs[poly_mul_cst_def, poly_mul_cst_aux_def, reduce_def] + >> Cases_on ‘reduce (poly_mul_cst_aux (coeff p (deg p))⁻¹ p) = []’ + >- gs[zerop_def, reduce_def] + >> gs[zerop_def, reduce_def, reduce_idempotent] +QED + +Theorem nonzero_last_coeff: + ~ zerop p2 ⇒ + coeff p2 (deg p2) ≠ 0 +Proof + Induct_on ‘p2’ + >- gs[zerop_def, reduce_def] + >> rpt strip_tac + >> Cases_on ‘reduce p2 = []’ + >- ( gs[zerop_def, reduce_def, coeff_def, oEL_def] + >> ‘deg (h :: p2) = 0’ by + ( gs[deg_def, reduce_def] + >> cond_cases_tac >> gs[] + ) + >> gs[] + ) + >> ‘0 < deg (h::p2)’ by gs[deg_def, reduce_def, length_gt_0] + >> ‘ coeff (h::p2) (deg (h::p2)) = coeff p2 (deg p2)’ by gs[coeff_cons] + >> ‘¬zerop p2’ by gs[zerop_def] + >> gs[] +QED + +Theorem sturm_equiv: + ∀ n p1 p2 ps. + sturm_seq_aux n p1 p2 = SOME ps ⇒ + STURM p1 p2 ps +Proof + Induct_on ‘n’ + >- ( + gs[STURM_def, sturm_seq_aux_def, poly_divides, rm_def] + >> rpt gen_tac + >> qmatch_goalsub_abbrev_tac ‘SND (divmod p1 p2_norm) = _’ + >> rpt strip_tac + >> Cases_on ‘divmod p1 p2_norm’ >> gs[FUN_EQ_THM, POLY_MUL] + >> ‘coeff p2_norm (deg p2_norm) = 1’ + by (unabbrev_all_tac >> gs[normalized_normal]) + >> ‘~ zerop p2_norm’ + by (unabbrev_all_tac >> gs[nonzero_normalize]) + >> drule divmod_coeff_1 + >> rpt $ disch_then drule + >> gs[poly_add_lid, reduce_preserving] + >> gs[FUN_EQ_THM, eval_simps, poly_compat] + >> rpt strip_tac + >> unabbrev_all_tac + >> qexists_tac ‘inv (coeff p2 (deg p2)) *c q’ + >> gs[GSYM poly_compat, eval_simps] + >> rpt strip_tac + >> qpat_x_assum ‘∀ x. _ = _’ kall_tac >> real_tac) + >> gs[sturm_seq_aux_def] + >> rpt gen_tac >> cond_cases_tac + >- ( + gs[STURM_def, sturm_seq_aux_def, poly_divides, rm_def] + >> ntac 2 $ pop_assum $ mp_tac + >> qmatch_goalsub_abbrev_tac ‘SND (divmod p1 p2_norm) = _’ + >> rpt strip_tac + >> Cases_on ‘divmod p1 p2_norm’ >> gs[FUN_EQ_THM, POLY_MUL] + >> ‘coeff p2_norm (deg p2_norm) = 1’ + by (unabbrev_all_tac >> gs[normalized_normal]) + >> ‘~ zerop p2_norm’ + by (unabbrev_all_tac >> gs[nonzero_normalize]) + >> drule divmod_coeff_1 + >> rpt $ disch_then drule + >> gs[poly_add_lid, reduce_preserving] + >> gs[FUN_EQ_THM, eval_simps, poly_compat] + >> rpt strip_tac + >> unabbrev_all_tac + >> qexists_tac ‘inv (coeff p2 (deg p2)) *c q’ + >> gs[GSYM poly_compat, eval_simps]) + >> cond_cases_tac + >> gs[CaseEq"option"] + >> rpt strip_tac >> VAR_EQ_TAC + >> gs[STURM_def] >> reverse conj_tac + >- ( + gs[GSYM deg_degree, rm_def] + >> qmatch_goalsub_abbrev_tac ‘deg (--p (SND (divmod _ p2_norm)))’ + >> Cases_on ‘divmod p1 p2_norm’ >> gs[] + >> ‘~ zerop p2_norm’ + by (unabbrev_all_tac >> gs[nonzero_normalize]) + >> drule_then drule divmod_correct + >> ‘coeff p2 (deg p2) ≠ 0’ by gs[nonzero_last_coeff] + >> rpt strip_tac >> unabbrev_all_tac + >> gs[deg_poly_neg, deg_of_const_mul, deg_def, zerop_def]) + >> gs[poly_divides, FUN_EQ_THM, POLY_ADD, POLY_CMUL] + >> gs[GSYM poly_compat, eval_simps] + >> qexists_tac ‘1’ >> gs[poly_compat, POLY_MUL] + >> gs[GSYM poly_compat, rm_def] + >> qmatch_goalsub_abbrev_tac ‘SND (divmod _ p2_norm)’ + >> Cases_on ‘divmod p1 p2_norm’ >> gs[] + >> ‘~ zerop p2_norm’ + by (unabbrev_all_tac >> gs[nonzero_normalize]) + >> ‘coeff p2_norm (deg p2_norm) = 1’ + by (unabbrev_all_tac >> gs[normalized_normal]) + >> drule divmod_coeff_1 + >> rpt $ disch_then drule + >> disch_then (fn th => assume_tac $ CONJUNCT1 th) + >> unabbrev_all_tac + >> gs[FUN_EQ_THM, eval_simps] + >> qexists_tac ‘inv (coeff p2 (deg p2)) *c q’ + >> strip_tac >> gs[eval_simps] + >> pop_assum kall_tac >> last_x_assum kall_tac >> real_tac +QED + +Theorem reduce_nonzero: + reduce p ≠ [] ⇒ + ~ (EVERY (λ c. c = 0) p) +Proof + Induct_on ‘p’ >> gs[reduce_def] + >> cond_cases_tac >> gs[] +QED + +Theorem reduce_not_zero: + reduce p ≠ [] ⇒ + ∃ x. evalPoly (reduce p) x ≠ 0 +Proof + gs[reduce_preserving] >> gs[poly_compat] >> rpt strip_tac + >> CCONTR_TAC >> gs[] + >> ‘poly p = poly []’ by (gs[FUN_EQ_THM, poly_def]) + >> gs[POLY_ZERO] + >> imp_res_tac reduce_nonzero +QED + +Theorem sturm_seq_aux_length: + ∀ n p q sseq. + sturm_seq_aux n p q = SOME sseq ⇒ + LENGTH sseq ≤ n +Proof + Induct_on ‘n’ >> gs[sturm_seq_aux_def] + >> rpt gen_tac >> cond_cases_tac + >> rpt strip_tac >> gs[CaseEq"option"] + >> rpt VAR_EQ_TAC >> res_tac >> gs[] +QED + +Theorem sturm_seq_equiv: + sturm_seq p q = SOME sseq ⇒ + poly q ≠ poly [] ∧ sseq ≠ [] ∧ + (∃ d. d ≠ 0 ∧ LAST sseq = [d]) ∧ + STURM p q sseq +Proof + gs[sturm_seq_def, CaseEq"option", CaseEq"list"] + >> rpt $ disch_then strip_assume_tac + >> imp_res_tac sturm_equiv >> gs[] + >> gs[zerop_def] + >> rpt conj_tac + >- ( + gs[FUN_EQ_THM, GSYM poly_compat, Once $ GSYM reduce_preserving, + evalPoly_def] + >> imp_res_tac reduce_not_zero + >> fsrw_tac [SATISFY_ss] [reduce_idempotent]) + >- ( imp_res_tac oEL_EQ_EL >> Cases_on ‘sseq’ >> gs[]) + >> imp_res_tac oEL_EQ_EL + >> ‘sseq ≠ []’ by (Cases_on ‘sseq’ >> gs[]) + >> pop_assum $mp_then Any mp_tac LAST_EL + >> disch_then $ once_rewrite_tac o single + >> pop_assum $ once_rewrite_tac o single o GSYM + >> gs[] +QED + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/sturmScript.sml b/floatingPoint/tools/dandelion/sturmScript.sml new file mode 100644 index 0000000000..b725cf275b --- /dev/null +++ b/floatingPoint/tools/dandelion/sturmScript.sml @@ -0,0 +1,2120 @@ +(** + Proof of Sturm's theorem, ported from Harrison material +**) +open pred_setTheory listTheory bossLib RealArith realTheory polyTheory; +open renameTheory; +open preambleDandelion; + +val _ = new_theory "sturm"; + +(** HOL-Light compatibility **) +val REAL_MUL_AC = REAL_MUL_ASSOC; +val SPEC = Q.SPEC; +val SPECL = Q.SPECL; +val REAL_ARITH = fn t => REAL_ARITH (Term t); +val SUBGOAL_THEN = fn t => SUBGOAL_THEN (Term t); +val UNDISCH_TAC = fn t => UNDISCH_TAC (Term t); +val EXISTS_TAC = fn t => EXISTS_TAC (Term t); +val GEN_REWRITE_TAC = jrhUtils.GEN_REWR_TAC; + +(* ========================================================================= *) +(* Formalization of Sturm sequences and Sturm's theorem. *) +(* ========================================================================= *) + +(** +do_list override_interface + ["divides",`poly_divides:real list->real list->bool`; + "exp",`poly_exp:real list -> num -> real list`; + "diff",`poly_diff:real list->real list`];; **) + +(* ------------------------------------------------------------------------- *) +(* Dreary lemmas about sign alternations. *) +(* ------------------------------------------------------------------------- *) + +Theorem SIGN_LEMMA0: + ! a b c:real. + &0 < a /\ &0 < b /\ &0 < c ==> + &0 < a * b /\ &0 < a * c /\ &0 < b * c +Proof + rpt strip_tac >> irule REAL_LT_MUL >> gs[] +QED + +Theorem SIGN_LEMMA1: + !a b c:real. a * b > &0 ==> (c * a < &0 <=> c * b < &0) +Proof + REPEAT GEN_TAC >> REWRITE_TAC[real_gt] + >> REPEAT_TCL DISJ_CASES_THEN ASSUME_TAC (SPEC `a:real` REAL_LT_NEGTOTAL) + >> REPEAT_TCL DISJ_CASES_THEN ASSUME_TAC (SPEC `b:real` REAL_LT_NEGTOTAL) + >> REPEAT_TCL DISJ_CASES_THEN ASSUME_TAC (SPEC `c:real` REAL_LT_NEGTOTAL) + >> ASM_REWRITE_TAC[REAL_MUL_RZERO, REAL_MUL_LZERO, REAL_LT_REFL] + >> POP_ASSUM_LIST(MP_TAC o MATCH_MP SIGN_LEMMA0 o end_itlist CONJ) + >> REWRITE_TAC[REAL_MUL_LNEG, REAL_MUL_RNEG, REAL_NEG_NEG] + >> REWRITE_TAC[REAL_MUL_AC] >> REAL_ARITH_TAC +QED + +Theorem SIGN_LEMMA2: + !a b c:real. a * b > &0 ==> (a * c < &0 <=> b * c < &0) +Proof + REPEAT GEN_TAC + >> DISCH_THEN(MP_TAC o SPEC_ALL o MATCH_MP SIGN_LEMMA1) + >> REAL_ARITH_TAC +QED + +Theorem SIGN_LEMMA3: + !a b:real. a < &0 ==> (a * b > &0 <=> b < &0) +Proof + REPEAT GEN_TAC + >> REWRITE_TAC[REAL_ARITH `a:real < &0 <=> -(&1) * a > &0`] + >> DISCH_THEN(MP_TAC o MATCH_MP SIGN_LEMMA1) + >> DISCH_THEN(MP_TAC o SPEC `-b`) + >> REWRITE_TAC[REAL_MUL_AC, real_gt, REAL_MUL_LNEG, REAL_MUL_RNEG, + REAL_NEG_NEG, REAL_MUL_LID, REAL_MUL_RID] >> REAL_ARITH_TAC +QED + +Theorem SIGN_LEMMA5: + (a:real) * b < &0 <=> a > &0 /\ b < &0 \/ a < &0 /\ b > &0 +Proof + REPEAT_TCL DISJ_CASES_THEN ASSUME_TAC + (SPEC `a:real` REAL_LT_NEGTOTAL) + >> REPEAT_TCL DISJ_CASES_THEN ASSUME_TAC + (SPEC `b:real` REAL_LT_NEGTOTAL) + >> gs[REAL_MUL_LZERO, REAL_MUL_RZERO, REAL_LT_REFL, real_gt] + >> POP_ASSUM_LIST(MP_TAC o end_itlist CONJ) + >> DISCH_THEN(fn th => MP_TAC th >> ASSUME_TAC th) + >-( + POP_ASSUM(MP_TAC o MATCH_MP REAL_LT_MUL) + >> REWRITE_TAC[REAL_MUL_LNEG, REAL_MUL_RNEG, REAL_NEG_NEG] + >> REAL_ARITH_TAC) + >- ( + rpt strip_tac >> ‘0 = a * 0’ by REAL_ARITH_TAC + >> pop_assum $ once_rewrite_tac o single + >> irule REAL_LT_LMUL_IMP >> gs[]) + >- ( + rpt strip_tac >> ‘0 = 0 * b’ by REAL_ARITH_TAC + >> pop_assum $ once_rewrite_tac o single + >> irule REAL_LT_RMUL_IMP >> gs[]) + >> rpt strip_tac >> EQ_TAC >> rpt strip_tac >> gs[] + >- ( + ‘0 < -a ∧ 0 < -b’ by (conj_tac >> REAL_ASM_ARITH_TAC) + >> ‘0 < -a * -b’ by (irule REAL_LT_MUL >> gs[]) + >> gs[REAL_MUL_LNEG, REAL_MUL_RNEG, REAL_NEG_NEG] + >> ‘0 < 0’ by REAL_ASM_ARITH_TAC + >> gs[]) + >> REAL_ASM_ARITH_TAC +QED + +Theorem SIGN_LEMMA4: + !a b c:real. a * b < &0 /\ ~(c = &0) ==> (c * a < &0 <=> ~(c * b < &0)) +Proof + REPEAT STRIP_TAC + >> MP_TAC(SPECL [`a:real`, `-b`, `c:real`] SIGN_LEMMA2) + >> ASM_REWRITE_TAC[REAL_MUL_RNEG, real_gt] + >> ASM_REWRITE_TAC[REAL_ARITH `&0 < -a:real <=> a:real < &0`] + >> REWRITE_TAC[REAL_MUL_AC] >> DISCH_THEN SUBST1_TAC + >> REWRITE_TAC[REAL_MUL_RNEG, REAL_MUL_AC] + >> SUBGOAL_THEN `~((b:real) * (c:real) = &0)` MP_TAC + >- ( + ASM_REWRITE_TAC[REAL_ENTIRE, DE_MORGAN_THM] + >> DISCH_TAC >> UNDISCH_TAC `(a:real) * (b:real) < &0` + >> ASM_REWRITE_TAC[REAL_MUL_LZERO, REAL_MUL_RZERO, REAL_LT_REFL] + ) + >> rpt strip_tac >> EQ_TAC >> strip_tac >> gs[SIGN_LEMMA5] + >> REAL_ASM_ARITH_TAC +QED + +Theorem SIGN_LEMMA6: + !a b:real. a * b <= &0 <=> a >= &0 /\ b <= &0 \/ a <= &0 /\ b >= &0 +Proof + REWRITE_TAC[real_ge, REAL_LE_LT, REAL_ENTIRE, SIGN_LEMMA5] >> rpt gen_tac + >> Cases_on `a = &0` >> Cases_on `b = &0` + >> ASM_REWRITE_TAC[REAL_MUL_LZERO, REAL_MUL_RZERO, REAL_LT_REFL] + >> REWRITE_TAC[real_gt] + >> (REAL_ARITH_TAC ORELSE metis_tac[]) +QED + +(* ------------------------------------------------------------------------- *) +(* The number of variations in sign of a list of reals. *) +(* ------------------------------------------------------------------------- *) + +Definition varrec_def: + varrec prev [] = 0 ∧ + varrec prev (CONS h t) = + if prev * (h:real) < &0 then SUC(varrec h t) + else if h = &0 then varrec prev t + else varrec (h:real) (t:real list) +End + +Definition variation_def: + variation (l:real list) = varrec (&0) (l:real list) +End + +(* ------------------------------------------------------------------------- *) +(* Show that it depends only on the sign of the "previous element". *) +(* ------------------------------------------------------------------------- *) + +Theorem VARREC_SIGN: + !(l:real list) (r s:real). r * s > &0 ==> (varrec r l = varrec s l) +Proof + Induct_on ‘l’ >> REPEAT GEN_TAC >> REWRITE_TAC[varrec_def] + >> DISCH_TAC + >> FIRST_ASSUM(fn th => REWRITE_TAC[MATCH_MP SIGN_LEMMA2 th]) + >> Cases_on `s * h < &0` >> ASM_REWRITE_TAC[] + >> COND_CASES_TAC >> REWRITE_TAC[] + >> FIRST_ASSUM MATCH_MP_TAC >> ASM_REWRITE_TAC[] +QED + +(* ------------------------------------------------------------------------- *) +(* Middle is irrelevant if surrounding elements have opposite sign. *) +(* ------------------------------------------------------------------------- *) + +Theorem VARREC_STRADDLE: + !f g h x. + poly f x * poly h x < &0 ⇒ + (varrec (poly f x) (MAP (\p. poly p x) (CONS g (CONS h l))) = + SUC (varrec (poly h x) (MAP (\p. poly p x) l))) +Proof + REPEAT GEN_TAC >> REWRITE_TAC[listTheory.MAP, varrec_def] + >> Cases_on `poly h x = &0` + >> Cases_on `poly g x = &0` + >> ASM_REWRITE_TAC[REAL_MUL_LZERO, REAL_MUL_RZERO, real_gt, REAL_LT_REFL] + >- (gs[]) + >> DISCH_TAC >> ASM_REWRITE_TAC[] + >> jrhUtils.GEN_REWR_TAC (LAND_CONV o RATOR_CONV o RATOR_CONV o RAND_CONV o LAND_CONV) + [REAL_MUL_SYM] + >> MP_TAC(SPECL [`poly f x`, `poly h x`, `poly g x`] SIGN_LEMMA4) + >> ASM_REWRITE_TAC[] >> DISCH_THEN SUBST1_TAC >> + Cases_on `poly g x * poly h x < &0` >> gs[SIGN_LEMMA5] + >> TRY COND_CASES_TAC >> gs[] >> REAL_ASM_ARITH_TAC +QED + +(* ------------------------------------------------------------------------- *) +(* Property of being a (standard) Sturm sequence. *) +(* ------------------------------------------------------------------------- *) + +Definition STURM_def: + STURM f f' [] = f' poly_divides f ∧ + STURM f f' (g::gs) = ((∃ k. &0 < k ∧ f' poly_divides (f + k ## g)) ∧ + degree g < degree f' ∧ STURM f' g gs) +End + +(* ------------------------------------------------------------------------- *) +(* If a polynomial doesn't have a root in an interval, sign doesn't change. *) +(* ------------------------------------------------------------------------- *) + +Theorem STURM_NOROOT: + ∀ a b p. + a ≤ b ∧ + (∀ x. a <= x /\ x <= b ==> ~(poly p x = &0)) ⇒ + poly p a * poly p b > &0 +Proof + REPEAT GEN_TAC >> REWRITE_TAC[real_gt] + >> jrhUtils.GEN_REWR_TAC (LAND_CONV o LAND_CONV) [REAL_LE_LT] + >> DISCH_THEN(CONJUNCTS_THEN2 DISJ_CASES_TAC ASSUME_TAC) + >- ( + SUBGOAL_THEN `~(poly p a = &0) /\ ~(poly p b = &0)` STRIP_ASSUME_TAC + >- ( + CONJ_TAC >> FIRST_ASSUM MATCH_MP_TAC + >> UNDISCH_TAC `a:real < b:real` >> REAL_ARITH_TAC + ) + >> REPEAT_TCL DISJ_CASES_THEN MP_TAC (SPEC `poly p a` REAL_LT_NEGTOTAL) + >> REPEAT_TCL DISJ_CASES_THEN MP_TAC (SPEC `poly p b` REAL_LT_NEGTOTAL) + >> ASM_REWRITE_TAC[] + >> REWRITE_TAC[PROVE [] “a ==> b ==> c <=> b /\ a ==> c”] + >> TRY(DISCH_THEN(MP_TAC o MATCH_MP REAL_LT_MUL) + >> REWRITE_TAC[REAL_MUL_LNEG, REAL_MUL_RNEG, REAL_NEG_NEG] + >> NO_TAC) + >> REWRITE_TAC[REAL_ARITH `&0 < -a:real <=> a:real < &0`] + >> REWRITE_TAC[REAL_ARITH `&0 < x:real <=> x:real > &0`] + >> UNDISCH_TAC `a:real < b:real` + >> REWRITE_TAC[GSYM satTheory.AND_IMP] THENL + [DISCH_THEN(Q.X_CHOOSE_THEN `x:real` MP_TAC o MATCH_MP POLY_IVT_NEG), + DISCH_THEN(Q.X_CHOOSE_THEN `x:real` MP_TAC o MATCH_MP POLY_IVT_POS)] + >> REPEAT(DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC)) + >> CONV_TAC CONTRAPOS_CONV >> DISCH_TAC + >> FIRST_ASSUM MATCH_MP_TAC >> CONJ_TAC + >> MATCH_MP_TAC REAL_LT_IMP_LE >> ASM_REWRITE_TAC[]) + >> gs[] +QED + +(* ------------------------------------------------------------------------- *) +(* Now we get the changes in the variation. *) +(* ------------------------------------------------------------------------- *) + +Theorem STURM_NOROOT_NOVAR_LEMMA: + ∀ f a b l. + a <= b ∧ + (∀ x. a <= x /\ x <= b ==> ~(poly f x = &0)) ⇒ + (varrec r (MAP (\p. poly p a) (CONS f l)) + + varrec (poly f a) (MAP (\p. poly p b) l) = + varrec r (MAP (\p. poly p b) (CONS f l)) + + varrec (poly f a) (MAP (\p. poly p a) l)) +Proof + REPEAT GEN_TAC >> DISCH_TAC + >> jrhUtils.GEN_REWR_TAC (LAND_CONV o LAND_CONV o RAND_CONV) [listTheory.MAP] + >> jrhUtils.GEN_REWR_TAC (RAND_CONV o LAND_CONV o RAND_CONV) [listTheory.MAP] + >> REWRITE_TAC[varrec_def] + >> FIRST_ASSUM(ASSUME_TAC o MATCH_MP STURM_NOROOT) + >> FIRST_ASSUM(ASSUME_TAC o MATCH_MP SIGN_LEMMA1) + >> FIRST_ASSUM(ASSUME_TAC o MATCH_MP VARREC_SIGN) + >> ASM_REWRITE_TAC[] + >> SUBGOAL_THEN `~(poly f a = &0) /\ ~(poly f b = &0)` STRIP_ASSUME_TAC + >- ( + CONJ_TAC >> FIRST_ASSUM(MATCH_MP_TAC o CONJUNCT2) + >> ASM_REWRITE_TAC[REAL_LE_REFL]) + >> ASM_REWRITE_TAC[] + >> COND_CASES_TAC >> gs[] +QED + +Theorem STURM_NOROOT_NOVAR: + ∀ f a b l. + a <= b ∧ + (∀ x. a <= x /\ x <= b ==> ~(poly f x = &0)) ∧ + (varrec (poly f a) (MAP (\p. poly p a) l) = + varrec (poly f a) (MAP (\p. poly p b) l)) ⇒ + (varrec r (MAP (\p. poly p a) (CONS f l)) = + varrec r (MAP (\p. poly p b) (CONS f l))) +Proof + REPEAT GEN_TAC >> REWRITE_TAC[CONJ_ASSOC] + >> DISCH_THEN(CONJUNCTS_THEN2 MP_TAC ASSUME_TAC) + >> DISCH_THEN(MP_TAC o SPEC_ALL o MATCH_MP STURM_NOROOT_NOVAR_LEMMA) + >> gs[] +QED + +fun check (f:term -> bool) t = if f t then t else raise Feedback.mk_HOL_ERR "" "" "" + +Theorem STURM_NOVAR_LEMMA: + ∀ n l f f' c. + (LENGTH l = n) ∧ + STURM f f' l ∧ + a <= c ∧ c <= b ∧ + (∀ x. + a <= x /\ x <= b /\ EXISTS (\p. poly p x = &0) (CONS f (CONS f' l)) ⇒ + (x = c)) ∧ + ~(poly f c = &0) ⇒ + (varrec (poly f a) (MAP (\p. poly p a) (CONS f' l)) = + varrec (poly f b) (MAP (\p. poly p b) (CONS f' l))) +Proof + completeInduct_on ‘n’ >> rpt GEN_TAC >> DISCH_TAC + >> Induct_on ‘l’ >> REWRITE_TAC[STURM_def] + >- ( + REPEAT STRIP_TAC >>SUBGOAL_THEN `~(poly f' c = &0)` ASSUME_TAC + >- ( + UNDISCH_TAC `~(poly f c = &0)` >> CONV_TAC CONTRAPOS_CONV + >> REWRITE_TAC[] >> DISCH_TAC + >> UNDISCH_TAC `f' poly_divides f` >> REWRITE_TAC[poly_divides] + >> DISCH_THEN(CHOOSE_THEN SUBST1_TAC) + >> ASM_REWRITE_TAC[POLY_MUL, REAL_MUL_LZERO] + ) + >> FIRST_ASSUM(Tactic.UNDISCH_TAC o check is_forall o concl) + >> REWRITE_TAC[listTheory.EXISTS_DEF] >> DISCH_TAC + >> SUBGOAL_THEN `(!x. a <= x /\ x <= b ==> ~(poly f x = &0)) /\ + (!x. a <= x /\ x <= b ==> ~(poly f' x = &0))` + STRIP_ASSUME_TAC + >- mesonLib.ASM_MESON_TAC[] + >> `a:real <= b:real` + by ( UNDISCH_TAC `c:real <= b:real` >> UNDISCH_TAC `a:real <= c:real` >> REAL_ARITH_TAC) + >> MATCH_MP_TAC EQ_TRANS + >> Q.EXISTS_TAC `varrec (poly f b) (MAP (\p. poly p a) [f'])` + >> CONJ_TAC + >- ( + MATCH_MP_TAC VARREC_SIGN + >> MATCH_MP_TAC STURM_NOROOT >> ASM_REWRITE_TAC[] + ) + >> MATCH_MP_TAC STURM_NOROOT_NOVAR >> ASM_REWRITE_TAC[] + >> REWRITE_TAC[listTheory.MAP] + ) + >> REPEAT STRIP_TAC + >> `!x. a <= x /\ x <= b ==> ~(poly f x = &0)` by + ( + UNDISCH_TAC `~(poly f c = &0)` + >> UNDISCH_TAC ‘∀x. a ≤ x ∧ x ≤ b ∧ + EXISTS (λp. poly p x = 0) (f::f'::h::l) ⇒ x = c’ + >> REWRITE_TAC[listTheory.EXISTS_DEF] >> mesonLib.MESON_TAC[] + ) + >> `a:real <= b:real` by + ( UNDISCH_TAC `c:real <= b:real` >> UNDISCH_TAC `a:real <= c:real` >> REAL_ARITH_TAC ) + >> MATCH_MP_TAC EQ_TRANS + >> EXISTS_TAC + `varrec (poly f b) (MAP (\p. poly p a) (CONS f' (CONS h l)))` + >> CONJ_TAC + >- ( + MATCH_MP_TAC VARREC_SIGN + >> MATCH_MP_TAC STURM_NOROOT >>ASM_REWRITE_TAC[] + ) + >> ASM_CASES_TAC “poly f' c = &0” >> ASM_REWRITE_TAC[] + >- ( + UNDISCH_TAC `f' poly_divides f + k ## h` + >> REWRITE_TAC[poly_divides] + >> DISCH_THEN(X_CHOOSE_THEN “q:real list” MP_TAC) + >> DISCH_THEN(MP_TAC o C AP_THM “c:real”) + >> REWRITE_TAC[POLY_MUL,POLY_ADD] + >> ASM_REWRITE_TAC[REAL_MUL_LZERO] + >> REWRITE_TAC[REAL_ARITH ‘((x:real) + (y:real) = &0) <=> (x = -y)’] + >> DISCH_TAC + >> `(!x. a <= x /\ x <= b ==> ~(poly f x = &0)) /\ + (!x. a <= x /\ x <= b ==> ~(poly h x = &0))` by + ( + CONJ_TAC + >- metis_tac[] + >> X_GEN_TAC “x:real” + >> UNDISCH_TAC `!x. a <= x /\ x <= b /\ + EXISTS (\p. poly p x = &0) (CONS f (CONS f' (CONS h l))) + ==> (x = c)` + >> DISCH_THEN(MP_TAC o SPEC `x:real`) + >> REWRITE_TAC[listTheory.EXISTS_DEF] + >> `(poly h c = &0) <=> (poly f c = &0)` by + ( + UNDISCH_TAC `poly f c = - (poly (k ## h) c)` + >> DISCH_THEN SUBST1_TAC >> REWRITE_TAC[POLY_CMUL] + >> REWRITE_TAC[GSYM REAL_MUL_LNEG] + >> REWRITE_TAC[REAL_ENTIRE] + >> ASM_CASES_TAC “poly h c = &0” + >- ASM_REWRITE_TAC[] + >> UNDISCH_TAC `&0 < k:real` >> REAL_ARITH_TAC + ) + >> pop_assum mp_tac + >> ASM_REWRITE_TAC[ASSUME “~(poly f c = &0)”] + >> UNDISCH_TAC `~(poly f c = &0)` >> mesonLib.MESON_TAC[] + ) + >> `poly f a * poly f b > &0 /\ + poly h a * poly h b > &0` + by + ( + CONJ_TAC + >- ( + MATCH_MP_TAC STURM_NOROOT >> metis_tac[] + ) + >> MATCH_MP_TAC STURM_NOROOT >> metis_tac[] + ) + >> SUBGOAL_THEN `(poly f a * poly h a < &0) /\ + (poly f b * poly h b < &0)` + MP_TAC + >- ( + SUBGOAL_THEN `a <= c /\ + (!x. a <= x /\ x <= c ==> ~(poly (f * h) x = &0))` + MP_TAC + >- ( + CONJ_TAC + >- ASM_REWRITE_TAC[] + >> REWRITE_TAC[REAL_ENTIRE, POLY_MUL, DE_MORGAN_THM] + >> GEN_TAC >> STRIP_TAC >> CONJ_TAC + >> FIRST_ASSUM MATCH_MP_TAC >> ASM_REWRITE_TAC[] + >> MATCH_MP_TAC REAL_LE_TRANS >> EXISTS_TAC `c:real` + >> ASM_REWRITE_TAC[] >> first_assum match_mp_tac + >> ASM_REWRITE_TAC[] + >> UNDISCH_TAC ‘x:real≤c:real’ >> UNDISCH_TAC ‘c:real≤b:real’ + >> REAL_ARITH_TAC + ) + >> DISCH_THEN(MP_TAC o MATCH_MP STURM_NOROOT) + >> SUBGOAL_THEN `c <= b /\ + (!x. c <= x /\ x <= b ==> ~(poly (f * h) x = &0))` + MP_TAC + >- ( + CONJ_TAC + >- ASM_REWRITE_TAC[] + >> REWRITE_TAC[REAL_ENTIRE, POLY_MUL, DE_MORGAN_THM] + >> GEN_TAC >> STRIP_TAC >> CONJ_TAC + >> FIRST_ASSUM MATCH_MP_TAC >> ASM_REWRITE_TAC[] + >> MATCH_MP_TAC REAL_LE_TRANS >> EXISTS_TAC `c:real` + >> ASM_REWRITE_TAC[] >> first_assum match_mp_tac + >> ASM_REWRITE_TAC[] >> UNDISCH_TAC ‘a:real≤c:real’ + >> UNDISCH_TAC ‘c:real ≤x:real’ >> REAL_ARITH_TAC + ) + >> DISCH_THEN(MP_TAC o MATCH_MP STURM_NOROOT) + >> SUBGOAL_THEN `poly (f * h) c < &0` MP_TAC + >- ( + ASM_REWRITE_TAC[POLY_MUL, REAL_MUL_LNEG] + >> REWRITE_TAC[REAL_ARITH `-x < &0 <=> &0 < x:real`, POLY_CMUL] + >> REWRITE_TAC[GSYM REAL_MUL_ASSOC] + >> MATCH_MP_TAC REAL_LT_MUL >> ASM_REWRITE_TAC[] + >> REWRITE_TAC[REAL_POSSQ] + >> FIRST_ASSUM MATCH_MP_TAC >> ASM_REWRITE_TAC[] + ) + >> GEN_REWRITE_TAC (RAND_CONV o RAND_CONV o LAND_CONV o LAND_CONV) + [REAL_MUL_SYM] + >> DISCH_THEN(fn th => REWRITE_TAC[MATCH_MP SIGN_LEMMA3 th]) + >> REWRITE_TAC[POLY_MUL] >> metis_tac[] + ) + >> DISCH_THEN(CONJUNCTS_THEN (ASSUME_TAC o MATCH_MP VARREC_STRADDLE)) + >> MATCH_MP_TAC EQ_TRANS + >> EXISTS_TAC + `varrec (poly f a) (MAP (\p. poly p a) (CONS f' (CONS h l)))` + >> CONJ_TAC + >- ( + MATCH_MP_TAC VARREC_SIGN >> ONCE_REWRITE_TAC[REAL_MUL_SYM] + >> ASM_REWRITE_TAC[] + ) + >> ASM_REWRITE_TAC[ arithmeticTheory.LESS_EQ_MONO] + >> MP_TAC(ISPEC “l:(real list)list” list_CASES) + >> DISCH_THEN(DISJ_CASES_THEN2 SUBST_ALL_TAC MP_TAC) + >- REWRITE_TAC[varrec_def, MAP] + >> DISCH_THEN(X_CHOOSE_THEN “g:real list” MP_TAC) + >> DISCH_THEN(X_CHOOSE_THEN “m:(real list)list” SUBST_ALL_TAC) + >> FIRST_ASSUM(MP_TAC o SPEC `PRE(PRE n)`) + >> UNDISCH_TAC `LENGTH (CONS (h:real list) (CONS g m)) = n` + >> REWRITE_TAC[LENGTH] THEN DISCH_THEN(SUBST_ALL_TAC o SYM) + >> ‘PRE (PRE (SUC (SUC (LENGTH m)))) = LENGTH m’ by rw[] + >> pop_assum $ rewrite_tac o single + >> ‘LENGTH m < SUC (SUC (LENGTH m))’ by rw[] + >> pop_assum $ rewrite_tac o single + >> DISCH_THEN(MP_TAC o SPECL [`m:(real list)list`, `h:real list`]) + >> DISCH_THEN(MP_TAC o SPECL [`g:real list`, `c:real`]) + >> ASM_REWRITE_TAC[] + >> ‘STURM h g m ∧ + (∀x. a ≤ x ∧ x ≤ b ∧ EXISTS (λp. poly p x = 0) (h::g::m) ⇒ x = c) + ∧ poly h c ≠ 0’ + by ( + CONJ_TAC + >- metis_tac[STURM_def] + >> CONJ_TAC + >- ( rpt strip_tac >> rw[] ) + >> first_assum match_mp_tac >> metis_tac[] + ) + >> rpt strip_tac >> AP_TERM_TAC + >> first_assum MATCH_MP_TAC >> metis_tac[] + ) + >> SUBGOAL_THEN `~(poly f' a = &0) /\ ~(poly f' b = &0)` + STRIP_ASSUME_TAC + >- ( + RULE_ASSUM_TAC(REWRITE_RULE[listTheory.EXISTS_DEF]) + >> mesonLib.ASM_MESON_TAC[REAL_LE_REFL, REAL_LT_REFL] + ) + >> FIRST_ASSUM(MP_TAC o SPEC `PRE n`) + >> UNDISCH_TAC `LENGTH (CONS (h:real list) l) = n` + >> REWRITE_TAC[LENGTH] >> DISCH_THEN(SUBST_ALL_TAC o SYM) + >> ‘PRE (SUC (LENGTH l)) = LENGTH l’ by rw[] + >> pop_assum $ rewrite_tac o single + >> ‘LENGTH l < SUC (LENGTH l)’ by rw[] + >> pop_assum $ rewrite_tac o single + >> DISCH_THEN(MP_TAC o SPECL [`l:(real list)list`, `f':real list`]) + >> DISCH_THEN(MP_TAC o SPECL [`h:real list`, `c:real`]) + >> RULE_ASSUM_TAC(REWRITE_RULE[STURM_def]) THEN ASM_REWRITE_TAC[] + >> W(C SUBGOAL_THEN (fn th => REWRITE_TAC[th]) o (fn t => `^t`) o lhand o lhand o snd) + >- ( + REWRITE_TAC[listTheory.EXISTS_DEF] + >> REPEAT STRIP_TAC >> FIRST_ASSUM MATCH_MP_TAC + >> ASM_REWRITE_TAC[listTheory.EXISTS_DEF] + >> first_assum match_mp_tac + >> ASM_REWRITE_TAC[listTheory.EXISTS_DEF] >> first_assum match_mp_tac + >> ASM_REWRITE_TAC[listTheory.EXISTS_DEF] + ) + >> DISCH_TAC + >> ONCE_REWRITE_TAC[MAP] >> REWRITE_TAC[varrec_def] + >> ASM_REWRITE_TAC[] + >> SUBGOAL_THEN `!x. a <= x /\ x <= b ==> ~(poly f' x = &0)` + ASSUME_TAC + >- ( + UNDISCH_TAC `~(poly f' c = &0)` + >> UNDISCH_TAC `!x. a <= x /\ x <= b /\ + EXISTS (\p. poly p x = &0) (CONS f (CONS f' (CONS h l))) + ==> (x = c)` + >> REWRITE_TAC[listTheory.EXISTS_DEF] >> mesonLib.MESON_TAC[] + ) + >> MP_TAC(SPECL [`a:real`, `b:real`, `f':real list`] STURM_NOROOT) + >> ASM_REWRITE_TAC[] >> rpt strip_tac + >> ‘(poly f b * poly f' a < &0) ⇔ (poly f b * poly f' b < &0)’ by + ( irule SIGN_LEMMA1 >> metis_tac[] ) + >> metis_tac[] +QED + +Theorem STURM_NOVAR: + ∀ l f f' c. + STURM f f' l ∧ + a ≤ c ∧ c ≤ b ∧ + (∀ x. + a ≤ x ∧ x ≤ b ∧ EXISTS (\p. poly p x = &0) (CONS f (CONS f' l)) ⇒ + (x = c)) ∧ + ~(poly f c = &0) ⇒ + (varrec (poly f a) (MAP (\p. poly p a) (CONS f' l)) = + varrec (poly f b) (MAP (\p. poly p b) (CONS f' l))) +Proof + REPEAT STRIP_TAC >> MATCH_MP_TAC STURM_NOVAR_LEMMA >> + MAP_EVERY EXISTS_TAC [`LENGTH(l:(real list) list)`, `c:real`] >> + ASM_REWRITE_TAC[] +QED + +Theorem STURM_VAR_DLEMMA: + !p a b. + a ≤ b ∧ + (!x. a <= x /\ x <= b ==> ~(poly p x = &0)) + ⇒ (!x. a <= x /\ x <= b ==> poly p x > &0) \/ + (!x. a <= x /\ x <= b ==> poly p x < &0) +Proof + REPEAT GEN_TAC >> STRIP_TAC + >> REPEAT_TCL DISJ_CASES_THEN ASSUME_TAC (SPEC `poly p a` REAL_LT_NEGTOTAL) + >- ( + FIRST_ASSUM(Tactic.UNDISCH_TAC o check is_forall o concl) + >> DISCH_THEN(MP_TAC o SPEC `a:real`) >> ASM_REWRITE_TAC[REAL_LE_REFL] + ) + >-( + DISJ1_TAC >> REPEAT STRIP_TAC >> REWRITE_TAC[real_gt] + >> SUBGOAL_THEN `~(poly p x = &0) /\ ~(poly p x < &0)` MP_TAC + >- ( + CONJ_TAC + >- ( FIRST_ASSUM MATCH_MP_TAC >> ASM_REWRITE_TAC[REAL_LE_REFL]) + >> DISCH_TAC >> MP_TAC(SPEC `p:real list` POLY_IVT_NEG) + >> DISCH_THEN(MP_TAC o SPECL [`a:real`, `x:real`]) + >> ASM_REWRITE_TAC[real_gt, NOT_IMP, NOT_EXISTS_THM, REAL_LT_REFL] + >> jrhUtils.GEN_REWR_TAC LAND_CONV [REAL_LT_LE] + >> ASM_REWRITE_TAC[] + >> ASM_CASES_TAC “a:real = x” + >- mesonLib.ASM_MESON_TAC[REAL_LT_ANTISYM] + >> ASM_REWRITE_TAC[] + >> ‘ (¬∃x'. a < x' ∧ x' < x ∧ poly p x' = 0) ⇔ + ∀x'. ~(a < x' ∧ x' < x ∧ poly p x'=0)’ by + (gs[NOT_EXISTS_THM]) + >> pop_assum $ rewrite_tac o single + >> X_GEN_TAC “y:real” + >> REWRITE_TAC[tautLib.TAUT `~(a /\ b /\ c) <=> a /\ b ==> ~c`] + >> DISCH_TAC + >> FIRST_ASSUM MATCH_MP_TAC + >> UNDISCH_TAC `a:real < y:real /\ y:real < x:real` + >> UNDISCH_TAC `x:real <= b:real` + >> REAL_ARITH_TAC + ) + >> REAL_ARITH_TAC + ) + >> DISJ2_TAC >> REPEAT STRIP_TAC + >> SUBGOAL_THEN `~(poly p x = &0) /\ ~(poly p x > &0)` MP_TAC + >- ( + CONJ_TAC + >- ( FIRST_ASSUM MATCH_MP_TAC >> ASM_REWRITE_TAC[REAL_LE_REFL] ) + >> DISCH_TAC >> MP_TAC(SPEC `p:real list` POLY_IVT_POS) + >> DISCH_THEN(MP_TAC o SPECL [`a:real`, `x:real`]) + >> RULE_ASSUM_TAC(Ho_Rewrite.REWRITE_RULE + [RealArith.REAL_ARITH “&0 < - x <=> x:real < &0”]) + >> ASM_REWRITE_TAC[real_gt, NOT_IMP, NOT_EXISTS_THM, REAL_LT_REFL] + >> GEN_REWRITE_TAC LAND_CONV [REAL_LT_LE] + >> ASM_REWRITE_TAC[] + >> ASM_CASES_TAC “a:real = x” + >- mesonLib.ASM_MESON_TAC[REAL_LT_ANTISYM, real_gt] + >> ASM_REWRITE_TAC[] + >> ‘(¬∃x'. a < x' ∧ x' < x ∧ poly p x' = 0) ⇔ + ∀x'. ~(a < x' ∧ x' < x ∧ poly p x'=0)’ + by (gs[NOT_EXISTS_THM]) + >> pop_assum $ rewrite_tac o single + >> X_GEN_TAC “y:real” + >> REWRITE_TAC[tautLib.TAUT `~(a /\ b /\ c) <=> a /\ b ==> ~c`] + >> DISCH_TAC >> FIRST_ASSUM MATCH_MP_TAC + >> UNDISCH_TAC `a:real < y:real /\ y:real < x:real` + >> UNDISCH_TAC `x:real <= b:real` + >> REAL_ARITH_TAC + ) + >> REAL_ARITH_TAC +QED + +Theorem STURM_VAR_LEMMA: + !l f f' c. + rsquarefree f /\ + (f' = diff f) /\ + STURM f f' l /\ + a < c /\ c < b /\ + (!x. a <= x /\ x <= b /\ EXISTS (\p. poly p x = &0) (CONS f (CONS f' l)) + ==> (x = c)) /\ + (poly f c = &0) + ==> poly f a * poly f' a < &0 /\ + poly f b * poly f' b > &0 +Proof + REPEAT GEN_TAC >> STRIP_TAC + >> SUBGOAL_THEN `a:real <= b:real` ASSUME_TAC + >- ( + UNDISCH_TAC `a:real < c:real` >> UNDISCH_TAC `c:real < b:real` + >> REAL_ARITH_TAC + ) + >> SUBGOAL_THEN `!x. a <= x /\ x <= b ==> ~(poly (diff f) x = &0)` ASSUME_TAC + >- ( + X_GEN_TAC “x:real” >> STRIP_TAC + >> FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I empty_rewrites [RSQUAREFREE_ROOTS]) + >> DISCH_THEN(MP_TAC o SPEC `c:real`) >> ASM_REWRITE_TAC[] + >> rpt strip_tac >> ‘x=c’ by (first_x_assum irule >> gs[listTheory.EXISTS_DEF]) + >> rpt BasicProvers.VAR_EQ_TAC + >> mesonLib.ASM_MESON_TAC[] + ) + >> MP_TAC(SPECL [`diff f`, `a:real`, `b:real`] STURM_VAR_DLEMMA) + >> ASM_REWRITE_TAC[] >> DISCH_THEN DISJ_CASES_TAC + >- ( + CONJ_TAC + >- ( + rewrite_tac[GSYM realTheory.REAL_NEG_GT0] + >> MP_TAC(SPECL [`f:real list`, `a:real`, `c:real`] POLY_MVT) + >> ASM_REWRITE_TAC[REAL_SUB_LZERO] + >> DISCH_THEN(X_CHOOSE_THEN “x:real” STRIP_ASSUME_TAC) + >> rewrite_tac[GSYM REAL_MUL_LNEG] + >> MATCH_MP_TAC REAL_LT_MUL + >> CONJ_TAC + >- ( + pop_assum $ rewrite_tac o single + >> MATCH_MP_TAC REAL_LT_MUL + >> CONJ_TAC + >- ( rewrite_tac[ REAL_SUB_LT] >> rw[] ) + >> REWRITE_TAC[REAL_ARITH `&0 < x <=> x:real > &0`] + >> first_assum irule >> rw[REAL_LT_IMP_LE] + >> UNDISCH_TAC `x:real < c:real` + >> UNDISCH_TAC `c:real < b:real` >> REAL_ARITH_TAC + ) + >> REWRITE_TAC[REAL_ARITH `&0 < x <=> x:real > &0`] + >> first_assum irule + >> CONJ_TAC + >- ASM_REWRITE_TAC[REAL_LE_REFL] + >> rw[] + ) + >> MP_TAC(SPECL [`f:real list`, `c:real`, `b:real`] POLY_MVT) + >> ASM_REWRITE_TAC[REAL_SUB_RZERO] + >> DISCH_THEN(X_CHOOSE_THEN “x:real” STRIP_ASSUME_TAC) + >> ‘∀x. &0 &0’ by rw[real_gt] + >> first_assum irule >> MATCH_MP_TAC REAL_LT_MUL + >> CONJ_TAC + >- ( + qpat_assum ‘poly f b = (b − c) * poly (diff f) x’$ rewrite_tac o single + >> MATCH_MP_TAC REAL_LT_MUL + >> CONJ_TAC + >- ( + UNDISCH_TAC `c:real < x:real` + >> UNDISCH_TAC `x:real < b:real` >> REAL_ARITH_TAC + ) + >> REWRITE_TAC[REAL_ARITH `&0 < x <=> x:real > &0`] + >> pop_assum $ kall_tac + >> first_assum irule + >> CONJ_TAC + >- ( + UNDISCH_TAC `a:real < c:real` >> UNDISCH_TAC `c:real < x:real` + >> REAL_ARITH_TAC + ) + >> rw[REAL_LT_IMP_LE] + ) + >> REWRITE_TAC[REAL_ARITH `&0 < x:real <=> x > &0`] + >> pop_assum $ kall_tac + >> first_assum irule + >> CONJ_TAC + >- rw[] + >> ASM_REWRITE_TAC[REAL_LE_REFL] + ) + >> CONJ_TAC + >- ( + rewrite_tac[GSYM realTheory.REAL_NEG_GT0] + >> MP_TAC(SPECL [`f:real list`, `a:real`, `c:real`] POLY_MVT) + >> ASM_REWRITE_TAC[REAL_SUB_LZERO] + >> DISCH_THEN(X_CHOOSE_THEN “x:real” STRIP_ASSUME_TAC) + >> rewrite_tac[REAL_NEG_RMUL] + >> MATCH_MP_TAC REAL_LT_MUL + >> CONJ_TAC + >- ( + rewrite_tac[GSYM realTheory.REAL_NEG_LT0] + >> pop_assum $ rewrite_tac o single + >> rewrite_tac[GSYM realTheory.REAL_NEG_GT0] + >> rewrite_tac[REAL_NEG_RMUL] + >> MATCH_MP_TAC REAL_LT_MUL + >> CONJ_TAC + >- ( rewrite_tac[REAL_SUB_LT] >> rw[] ) + >> rewrite_tac[realTheory.REAL_NEG_GT0] + >> first_assum irule + >> CONJ_TAC + >- rw[REAL_LT_IMP_LE] + >> UNDISCH_TAC `x:real < c:real` + >> UNDISCH_TAC `c:real < b:real` >> REAL_ARITH_TAC + ) + >> rewrite_tac[realTheory.REAL_NEG_GT0] + >> first_assum irule + >> CONJ_TAC + >- ASM_REWRITE_TAC[REAL_LE_REFL] + >> rw[] + ) + >> rewrite_tac[real_gt] + >> ONCE_REWRITE_TAC[REAL_ARITH `&0 < (x:real) * (y:real) <=> &0 < -x * - y` ] + >> MP_TAC(SPECL [`f:real list`, `c:real`, `b:real`] POLY_MVT) + >> ASM_REWRITE_TAC[REAL_SUB_RZERO] + >> DISCH_THEN(X_CHOOSE_THEN “x:real” STRIP_ASSUME_TAC) + >> MATCH_MP_TAC REAL_LT_MUL + >> CONJ_TAC + >- ( + pop_assum $ rewrite_tac o single + >> rewrite_tac[REAL_NEG_RMUL] + >> MATCH_MP_TAC REAL_LT_MUL + >> CONJ_TAC + >- ( rewrite_tac[REAL_SUB_LT] >> rw[] ) + >> rewrite_tac[realTheory.REAL_NEG_GT0] + >> first_assum irule + >> CONJ_TAC + >- ( + UNDISCH_TAC `a:real < c:real` >> UNDISCH_TAC `c:real < x:real` + >> REAL_ARITH_TAC + ) + >> rw[REAL_LT_IMP_LE] + ) + >> rewrite_tac[realTheory.REAL_NEG_GT0] + >> first_assum irule + >> CONJ_TAC + >- rw[] + >> ASM_REWRITE_TAC[REAL_LE_REFL] +QED + +Theorem STURM_VAR: + !l f f' c. + rsquarefree f /\ + (f' = diff f) /\ + STURM f f' l /\ + a < c /\ c < b /\ + (!x. a <= x /\ x <= b /\ EXISTS (\p. poly p x = &0) (CONS f (CONS f' l)) + ==> (x = c)) /\ + (poly f c = &0) + ==> (varrec (poly f a) (MAP (\p. poly p a) (CONS f' l)) = + SUC(varrec (poly f b) (MAP (\p. poly p b) (CONS f' l)))) +Proof + ListConv1.LIST_INDUCT_TAC + >- ( + REPEAT GEN_TAC + >> DISCH_THEN(STRIP_ASSUME_TAC o MATCH_MP STURM_VAR_LEMMA) + >> ASM_REWRITE_TAC[listTheory.MAP, varrec_def] + >> ‘~(poly f b * poly f' b < &0) /\ ~(poly f' b = &0)’ by + ( + UNDISCH_TAC `poly f b * poly f' b > &0` + >> ASM_CASES_TAC “poly f' b = &0” + >- ASM_REWRITE_TAC[real_gt, REAL_MUL_LZERO, REAL_MUL_RZERO, REAL_LT_REFL] + >> ASM_REWRITE_TAC[] >> REAL_ARITH_TAC + ) + >> gs[] + ) + >> REPEAT GEN_TAC >> DISCH_TAC + >> FIRST_ASSUM(STRIP_ASSUME_TAC o MATCH_MP STURM_VAR_LEMMA) + >> ONCE_REWRITE_TAC[listTheory.MAP] >> REWRITE_TAC[varrec_def] + >> ‘poly f a * poly f' a < &0 /\ + ~(poly f b * poly f' b < &0) /\ + ~(poly f' a = &0) /\ ~(poly f' b = &0)’ by + ( + UNDISCH_TAC `poly f b * poly f' b > &0` + >> UNDISCH_TAC `poly f a * poly f' a < &0` + >> POP_ASSUM_LIST(K ALL_TAC) + >> ASM_CASES_TAC “poly f' a = &0” + >- ASM_REWRITE_TAC + [real_gt, REAL_MUL_LZERO, REAL_MUL_RZERO, REAL_LT_REFL] + >> ASM_CASES_TAC “poly f' b = &0” + >- ASM_REWRITE_TAC + [real_gt, REAL_MUL_LZERO, REAL_MUL_RZERO, REAL_LT_REFL] + >> rpt strip_tac + >- metis_tac[] + >> assume_tac REAL_LT_ANTISYM + >> pop_assum $ qspecl_then [‘ poly f b * poly f' b’, ‘&0’] assume_tac + >> ‘(poly f b * poly f' b < 0 ∧ 0 < poly f b * poly f' b) ⇔ F’ + by metis_tac[] + >> first_assum match_mp_tac + >> CONJ_TAC + >- metis_tac[] + >> rewrite_tac[GSYM real_gt] >> metis_tac[] + ) + >> ‘poly f a * (λp. poly p a) f' < 0 ⇔ T’ by metis_tac[] + >> pop_assum $ rewrite_tac o single + >> ‘ poly f b * (λp. poly p b) f' < 0 ⇔ F’ by metis_tac[] + >> pop_assum $ rewrite_tac o single + >> ‘(λp. poly p b) f' = 0 ⇔ F’ by metis_tac[] + >> pop_assum $ rewrite_tac o single + >> AP_TERM_TAC + >> qpat_x_assum `_ /\ _ /\ _` mp_tac >> rpt strip_tac + >> `STURM f' h l` by + ( + qpat_x_assum `STURM _ _ _` $ mp_tac o REWRITE_RULE [STURM_def] + >> metis_tac[] + ) + >> pop_assum $ mp_then Any mp_tac STURM_NOVAR >> BETA_TAC + >> disch_then irule + >> EXISTS_TAC `c:real` + >> REPEAT CONJ_TAC + >- metis_tac[listTheory.EXISTS_DEF] + >- ( + MP_TAC(SPEC `f:real list` RSQUAREFREE_ROOTS) + >> ASM_REWRITE_TAC[] + >> DISCH_THEN(MP_TAC o SPEC `c:real`) >> ASM_REWRITE_TAC[] + ) + >> MATCH_MP_TAC REAL_LT_IMP_LE >> ASM_REWRITE_TAC[] +QED + +(* ------------------------------------------------------------------------- *) +(* The main lemma. *) +(* ------------------------------------------------------------------------- *) + +Theorem STURM_COMPONENT: + !l f a b c. + rsquarefree f /\ + STURM f (diff f) l /\ + a <= c /\ c <= b /\ + ~(poly f a = &0) /\ + ~(poly f b = &0) /\ + (!x. a <= x /\ x <= b /\ + EXISTS (\p. poly p x = &0) (CONS f (CONS (diff f) l)) + ==> (x = c)) + ==> (variation (MAP (\p. poly p a) (CONS f (CONS (diff f) l))) = + if poly f c = &0 then + SUC(variation (MAP (\p. poly p b) + (CONS f (CONS (diff f) l)))) + else variation (MAP (\p. poly p b) + (CONS f (CONS (diff f) l)))) +Proof + REPEAT STRIP_TAC >> REWRITE_TAC[variation_def] + >> ONCE_REWRITE_TAC[rich_listTheory.MAP] + >> REWRITE_TAC[varrec_def, REAL_MUL_LZERO, REAL_MUL_RZERO, REAL_LT_REFL] + >> ASM_CASES_TAC “poly f c = &0” + >- ( + ASM_REWRITE_TAC[] + >> ‘((λp. poly p a) f = 0) ⇔ F’ by metis_tac[] + >> pop_assum $ rewrite_tac o single + >> ‘ (λp. poly p b) f = 0 ⇔ F’ by metis_tac[] + >> pop_assum $ rewrite_tac o single + >> ‘((λp. poly p a) f) = poly f a’ by metis_tac[] + >> ‘((λp. poly p b) f) = poly f b’ by metis_tac[] + >> ASM_REWRITE_TAC[] >> irule STURM_VAR + >> rpt strip_tac + >- metis_tac[] + >- metis_tac[] + >- ( + EXISTS_TAC `c:real` + >> CONJ_TAC + >- metis_tac[] + >> CONJ_TAC + >- metis_tac[] + >> CONJ_TAC + >- ( ASM_REWRITE_TAC[REAL_LT_LE] >> metis_tac[] ) + >> ASM_REWRITE_TAC[REAL_LT_LE] >> metis_tac[] + ) + >> metis_tac[] + ) + >> ‘((λp. poly p a) f = 0) ⇔ F’ by metis_tac[] + >> pop_assum $ rewrite_tac o single + >> ‘ (λp. poly p b) f = 0 ⇔ F’ by metis_tac[] + >> pop_assum $ rewrite_tac o single + >> ‘((λp. poly p a) f) = poly f a’ by metis_tac[] + >> ‘((λp. poly p b) f) = poly f b’ by metis_tac[] + >> ‘poly f c = 0 ⇔ F’ by metis_tac[] + >> pop_assum $ rewrite_tac o single + >> ASM_REWRITE_TAC[] >> MATCH_MP_TAC STURM_NOVAR + >> EXISTS_TAC ‘c:real’ + >> rpt strip_tac + >- metis_tac[] + >- metis_tac[] + >- metis_tac[] + >> first_x_assum irule >> metis_tac[] +QED + +Theorem FINITE_UNION_IMP: + FINITE s ∧ FINITE t ⇒ FINITE (s UNION t) +Proof + gs[pred_setTheory.FINITE_UNION] +QED +(* ------------------------------------------------------------------------- *) +(* Roots of a list of polynomials (maybe in interval) is finite. *) +(* ------------------------------------------------------------------------- *) + +Theorem POLYS_ROOTS_FINITE_SET: + !l. EVERY (\p. ~(poly p = poly [])) l ==> + FINITE { x | EXISTS (\p. poly p x = &0) l } +Proof + ListConv1.LIST_INDUCT_TAC + >- ( + SUBGOAL_THEN `{ x | EXISTS (\p. poly p x = &0) [] } = {}` + (fn th => REWRITE_TAC[polyTheory.POLY_ROOTS_FINITE_SET, th]) + >> REWRITE_TAC[pred_setTheory.EXTENSION, pred_setTheory.NOT_IN_EMPTY, + listTheory.EXISTS_DEF] + >> gs[] + ) + >> SUBGOAL_THEN `{ x | EXISTS (\p. poly p x = &0) (CONS h t) } = + { x | poly h x = &0 } UNION { x | EXISTS (\p. poly p x = &0) t }` + SUBST1_TAC + >- ( + REWRITE_TAC[pred_setTheory.EXTENSION, pred_setTheory.IN_UNION, + listTheory.EXISTS_DEF] + >> gs[] + ) + >> REWRITE_TAC[listTheory.EVERY_DEF] >> STRIP_TAC + >> STRIP_TAC >> gs[] + >> ‘FINITE {x | poly h x = 0}’ by metis_tac[polyTheory.POLY_ROOTS_FINITE_SET] + >> imp_res_tac FINITE_UNION_IMP + >> rpt $ pop_assum mp_tac + >> rewrite_tac[pred_setTheory.UNION_DEF, IN_DEF] + >> simp[] +QED + +Theorem POLYS_INTERVAL_ROOTS_FINITE_SET: + !l a b. EVERY (\p. ~(poly p = poly [])) l ==> + FINITE { x | a <= x /\ x <= b /\ EXISTS (\p. poly p x = &0) l } +Proof + REPEAT GEN_TAC >> DISCH_TAC + >> MATCH_MP_TAC pred_setTheory.SUBSET_FINITE_I + >> EXISTS_TAC `{ x | EXISTS (\p. poly p x = &0) l }` + >> CONJ_TAC + >- ( MATCH_MP_TAC POLYS_ROOTS_FINITE_SET >> ASM_REWRITE_TAC[] ) + >> REWRITE_TAC[pred_setTheory.SUBSET_DEF] >> gs[] +QED + + +(* ------------------------------------------------------------------------- *) +(* Proof that we can lay out a finite set in a linear sequence. *) +(* ------------------------------------------------------------------------- *) + +Theorem FINITE_LEAST: + !(s:real -> bool). FINITE s ==> (s = {}) \/ ?a. a IN s /\ !x. x IN s ==> a <= x +Proof + qspec_then ‘\s:real->bool. s = ∅ ∨ ∃a. a ∈ s ∧ ∀x. x ∈ s ⇒ a ≤ x’ + mp_tac pred_setTheory.FINITE_INDUCT + >> reverse impl_tac + >- gs[] + >> rpt conj_tac + >> simp[] + >> rpt strip_tac + >- ( + EXISTS_TAC ‘e:real’ >> CONJ_TAC + >- ( DISJ1_TAC >> gs[] ) + >> strip_tac >> gs[] + ) + >> DISJ_CASES_TAC(SPECL [`a:real`, `e:real`] REAL_LE_TOTAL) + >- ( qexists_tac ‘a’ >> gs[] >> rpt strip_tac >> gs[] ) + >> qexists_tac ‘e’ >> gs[] >> rpt strip_tac >> gs[] + >> mesonLib.ASM_MESON_TAC[REAL_LE_TRANS, REAL_LE_REFL] +QED + + +Theorem FINITE_LEAST_DELETE : + !(s:real -> bool). s HAS_SIZE (SUC n) + ==> ?a. a IN s /\ (s DELETE a) HAS_SIZE n /\ + !x. x IN (s DELETE a) ==> a < x +Proof + GEN_TAC >> DISCH_THEN(fn th => MP_TAC th >> MP_TAC th) + >> DISCH_THEN(STRIP_ASSUME_TAC o REWRITE_RULE[pred_setTheory.HAS_SIZE_SUC]) + >> REWRITE_TAC[pred_setTheory.HAS_SIZE] + >> DISCH_THEN(MP_TAC o MATCH_MP FINITE_LEAST o CONJUNCT1) + >> ASM_REWRITE_TAC[] + >> DISCH_THEN(X_CHOOSE_THEN “a:real” STRIP_ASSUME_TAC) + >> EXISTS_TAC `a:real` >> ASM_REWRITE_TAC[] + >> REWRITE_TAC[GSYM pred_setTheory.HAS_SIZE, pred_setTheory.IN_DELETE] + >> REWRITE_TAC[REAL_LT_LE] >> mesonLib.ASM_MESON_TAC[] +QED + +Theorem HAS_SIZE_ORDER: + !n (s: real->bool). s HAS_SIZE n ==> + ?i. (!x. x IN s <=> ?k. k < n /\ (x = i k)) /\ + (!k. i k < i (SUC k)) +Proof + Induct_on ‘n’ + >- ( + GEN_TAC >> REWRITE_TAC[pred_setTheory.HAS_SIZE_0] + >> DISCH_THEN SUBST1_TAC + >> REWRITE_TAC[pred_setTheory.NOT_IN_EMPTY] >> gs[] + >> EXISTS_TAC `real_of_num` >> strip_tac >> gs[REAL_LT] + ) + >> GEN_TAC >> DISCH_THEN(MP_TAC o MATCH_MP FINITE_LEAST_DELETE) + >> DISCH_THEN(X_CHOOSE_THEN “a:real” (CONJUNCTS_THEN2 ASSUME_TAC MP_TAC)) + >> DISCH_THEN(CONJUNCTS_THEN2 MP_TAC ASSUME_TAC) + >> DISCH_THEN(fn th => ASSUME_TAC th >> MP_TAC th) + >> DISCH_THEN(ANTE_RES_THEN MP_TAC) + >> DISCH_THEN(X_CHOOSE_THEN “i:num->real” STRIP_ASSUME_TAC) + >> ASM_CASES_TAC “(n:num)=0” + >- ( + EXISTS_TAC `\(k:num). a + (&k:real)` >> gs[] >> rpt strip_tac >> eq_tac + >- ( + strip_tac >> EXISTS_TAC ‘(n:num)’ >> CONJ_TAC + >- gs[] + >> gs[] >> metis_tac[] + ) + >> strip_tac >> gs[] + >> ‘(k:num)=0’ by gs[] >> pop_assum $ rewrite_tac o single >> gs[] + ) + >> EXISTS_TAC `\k. if k = 0 then a:real else i(PRE k)` + >> REWRITE_TAC[] >> CONJ_TAC + >- ( + X_GEN_TAC “x:real” >> ASM_CASES_TAC “x:real = a” + >- ( + UNDISCH_TAC `x:real = a` >> DISCH_THEN SUBST_ALL_TAC + >> ASM_REWRITE_TAC[] >> EXISTS_TAC `0:num` + >> CONJ_TAC + >- gs[] + >> gs[] + ) + >> SUBGOAL_THEN `x IN s <=> x IN (s DELETE a:real)` SUBST1_TAC + >- ( REWRITE_TAC[IN_DELETE] >> ASM_REWRITE_TAC[] ) + >> ASM_REWRITE_TAC[] >> EQ_TAC + >- ( + DISCH_THEN(X_CHOOSE_THEN “k:num” STRIP_ASSUME_TAC) + >> EXISTS_TAC `SUC k` + >> CONJ_TAC + >- gs[arithmeticTheory.LT_SUC] + >> gs[] + ) + >> rpt strip_tac + >> EXISTS_TAC `PRE k` + >> `x = (if k = 0 then a:real else i (PRE k))` by gs[] + >> UNDISCH_TAC `x = (if k = 0 then a:real else i (PRE k))` + >> UNDISCH_TAC `k < SUC n` + >> SPEC_TAC(“k:num”,“k:num”) + >> rpt strip_tac + >- ( + Induct_on ‘k'’ + >- gs[] + >> rpt strip_tac >> gs[] + ) + >> Induct_on ‘k'’ + >- gs[] + >> rpt strip_tac >> gs[] + ) + >> rpt strip_tac >> gs[] + >> ASM_CASES_TAC “(k:num)=0” + >- ( + gs[] >> first_assum match_mp_tac + >> EXISTS_TAC `0:num` >> ASM_REWRITE_TAC[] + >> gs[] + ) + >> gs[] + >> qpat_assum ‘ ∀k. i k < i (SUC k)’ $ qspec_then ‘PRE k’ assume_tac + >> ‘SUC(PRE k) = k’ by gs[] + >> ‘i k = i (SUC (PRE k))’ by + ( pop_assum $ rewrite_tac o single) + >> pop_assum $ rewrite_tac o single >> metis_tac[] +QED + +Theorem FINITE_ORDER : + !(s:real -> bool). FINITE s ==> + ?i N. (!x. x IN s <=> ?k. k < N /\ (x = i k)) /\ + (!k. i k < i (SUC k)) +Proof + REPEAT STRIP_TAC + >> GEN_EXISTS_TAC "N" `CARD(s:real->bool)` + >> MATCH_MP_TAC HAS_SIZE_ORDER + >> ASM_REWRITE_TAC[HAS_SIZE] +QED + +(* ------------------------------------------------------------------------- *) +(* We can enumerate the roots in order. *) +(* ------------------------------------------------------------------------- *) + +Theorem POLYS_ENUM_ROOTS : + !l. EVERY (\p. ~(poly p = poly [])) l + ==> ?i N. (!k. i k < i (SUC k)) /\ + (!x. a <= x /\ x <= b /\ EXISTS (\p. poly p x = &0) l <=> + ?n:num. n < N /\ (x = i n)) +Proof + GEN_TAC + >> DISCH_THEN (MP_TAC o MATCH_MP POLYS_INTERVAL_ROOTS_FINITE_SET) + >> DISCH_THEN(MP_TAC o SPECL [`a:real`, `b:real`]) + >> DISCH_THEN(MP_TAC o MATCH_MP FINITE_ORDER) >> strip_tac + >> qexists_tac ‘i’ >> qexists_tac ‘N’ >> gs[] +QED + + +(* ------------------------------------------------------------------------- *) +(* Hence we can get separating intervals for the various roots. *) +(* ------------------------------------------------------------------------- *) + +Theorem lemma0[local]: + (!x y. x * inv(&2) <= y <=> x <= &2 * y) ∧ + (!x y. x <= y * inv(&2) <=> &2 * x <= y) +Proof + rpt strip_tac + >- ( + ‘&2*y = y* &2’ by metis_tac[REAL_MUL_COMM] + >> pop_assum $ rewrite_tac o single + >> ‘x* inv(&2) = x / &2’ by gs[GSYM real_div] + >> pop_assum $ rewrite_tac o single + >> irule REAL_LE_LDIV_EQ >> gs[] + ) + >> ‘&2 * x = x * &2’ by metis_tac[REAL_MUL_COMM] + >> pop_assum $ rewrite_tac o single + >> ‘y * inv(&2) = y / &2’ by gs[GSYM real_div] + >> pop_assum $ rewrite_tac o single + >> irule REAL_LE_RDIV_EQ >> gs[] +QED + + +Theorem lemma1[local]: + ∀x1 x2:real. a <= x1 /\ x1 < x2 ==> a <= (x1 + x2) / &2 +Proof + REWRITE_TAC[real_div, lemma0] >> REAL_ARITH_TAC +QED + +Theorem lemma2[local]: + ∀ x0 x1:real. x0 < x1 /\ x1 < x2 ==> (x0 + x1) / &2 <= (x1 + x2) / &2 +Proof + REWRITE_TAC[real_div, lemma0, REAL_MUL_ASSOC] + >> REAL_ARITH_TAC +QED + +Theorem lemma3[local]: + ∀x1 x2:real. x1 < x2 /\ x2 <= b ==> (x1 + x2) / &2 <= b +Proof + REWRITE_TAC[real_div, lemma0] >> REAL_ARITH_TAC +QED + +Theorem lemma8a[local]: + (!k. (i: num -> real) k < i(SUC k)) ==> !m n. m < n ==> i m < i n +Proof + STRIP_TAC >> GEN_TAC + >> rpt strip_tac + >> SUBGOAL_THEN ‘∃ (p:num). n = m + (p+1)’ MP_TAC + >- ( irule arithmeticTheory.LESS_ADD_1 >> gs[] ) + >> gs[boolTheory.PULL_EXISTS] + >> REWRITE_TAC[GSYM arithmeticTheory.ADD1] + >> Q.SPEC_TAC (`n`, `n`) >> Q.SPEC_TAC (`m`, `m`) + >> Induct_on ‘p’ + >- ( REWRITE_TAC[arithmeticTheory.ADD_CLAUSES] >> gs[] ) + >> REWRITE_TAC[arithmeticTheory.ADD_CLAUSES] + >> rpt STRIP_TAC + >> MATCH_MP_TAC REAL_LT_TRANS + >> EXISTS_TAC `i(SUC(m' + p)):real` >> gs[] + >> ‘SUC (m' + p) = m' + SUC p’ by REWRITE_TAC[arithmeticTheory.ADD_CLAUSES] + >> pop_assum $ once_rewrite_tac o single >> first_x_assum irule +QED + +Theorem lemma8b[local]: + (!k. (i: num->real) k < i(SUC k)) ==> !m n. i m < i n <=> m < n +Proof + DISCH_THEN(MP_TAC o MATCH_MP lemma8a) + >> mesonLib.MESON_TAC[REAL_LT_REFL, REAL_LT_ANTISYM, + arithmeticTheory.LESS_LESS_CASES] +QED + +Theorem lemma8[local]: + (!k. (i: num->real) k < i(SUC k)) ==> !m n. (i m <= i n) <=> m <= n +Proof + DISCH_THEN(MP_TAC o MATCH_MP lemma8b) + >> REWRITE_TAC[GSYM arithmeticTheory.NOT_LESS_EQUAL, GSYM REAL_NOT_LE] + >> mesonLib.MESON_TAC[] +QED + +Theorem lemma5[local]: + (!k. (i: num->real) k < i(SUC k)) ==> !k n. i k <= (i n + i(SUC n)) / &2 + ==> k <= n +Proof + DISCH_TAC + >> REWRITE_TAC[arithmeticTheory.LESS_EQ_IFF_LESS_SUC] + >> FIRST_ASSUM(fn th => REWRITE_TAC[GSYM(MATCH_MP lemma8b th)]) + >> REPEAT GEN_TAC >> REWRITE_TAC[real_div, lemma0] + >> POP_ASSUM(MP_TAC o SPEC `n:num`) >> REAL_ARITH_TAC +QED + +Theorem lemma6[local]: + (!k. (i:num->real) k < i(SUC k)) ==> !k n. (i k + i (SUC k)) / &2 <= i n + ==> SUC k <= n +Proof + DISCH_TAC >> REWRITE_TAC[GSYM arithmeticTheory.LESS_EQ] + >> FIRST_ASSUM(fn th => REWRITE_TAC[GSYM(MATCH_MP lemma8b th)]) + >> REPEAT GEN_TAC >> REWRITE_TAC[real_div, lemma0] + >> POP_ASSUM(MP_TAC o SPEC `k:num`) >> REAL_ARITH_TAC +QED + +Theorem lemma7[local]: + (!k. (i: num->real) k < i(SUC k)) ==> !k n. (i n + i(SUC n)) / &2 <= i k /\ + i k <= (i(SUC n) + i(SUC(SUC n))) / &2 + ==> (k = SUC n) +Proof + REPEAT STRIP_TAC + >> irule arithmeticTheory.LESS_EQUAL_ANTISYM + >> CONJ_TAC + >- ( FIRST_ASSUM(MATCH_MP_TAC o MATCH_MP lemma6) >> gs[] ) + >> FIRST_ASSUM(MATCH_MP_TAC o MATCH_MP lemma5) >> gs[] +QED + +Theorem lemma4[local]: + (!k. (i:num->real) k < i(SUC k)) ==> !k n. ~((i k + i (SUC k)) = 2 * i n) +Proof + DISCH_TAC >> REPEAT GEN_TAC + >> ONCE_REWRITE_TAC[GSYM REAL_LE_ANTISYM] >> STRIP_TAC + >> SUBGOAL_THEN `~(SUC k <= k)` MP_TAC + >- gs[] + >> REWRITE_TAC[] + >> MATCH_MP_TAC arithmeticTheory.LESS_EQ_TRANS + >> EXISTS_TAC `n:num` + >> CONJ_TAC + >- ( FIRST_ASSUM(MATCH_MP_TAC o MATCH_MP lemma6) >> gs[] ) + >> FIRST_ASSUM(MATCH_MP_TAC o MATCH_MP lemma5) >> gs[] +QED + +Theorem POLYS_INTERVAL_SEPARATION: + !f l a b. + a <= b /\ + EVERY (\p. ~(poly p = poly [])) l /\ + ~(poly f a = &0) /\ + ~(poly f b = &0) + ==> ?i N. (i 0 = a) /\ (i N = b) /\ + (!k. i(k) <= i(SUC k)) /\ + (!k. k <= N ==> ~(poly f (i k) = &0)) /\ + (!k. ?c. i(k) <= c /\ c <= i(SUC k) /\ + !x. i(k) <= x /\ x <= i(SUC k) /\ + EXISTS (\p. poly p x = &0) (CONS f l) + ==> (x = c)) +Proof + REPEAT STRIP_TAC + >> SUBGOAL_THEN `EVERY (\p. ~(poly p = poly [])) (CONS f l)` MP_TAC + >- ( + ASM_REWRITE_TAC[EVERY_DEF] >> UNDISCH_TAC `~(poly f a = &0)` + >> CONV_TAC CONTRAPOS_CONV >> REWRITE_TAC[] >> gs[] + >> REWRITE_TAC[poly_def] + ) + >> DISCH_THEN(MP_TAC o MATCH_MP POLYS_ENUM_ROOTS) + >> DISCH_THEN(X_CHOOSE_THEN “i:num->real” MP_TAC) + >> DISCH_THEN(X_CHOOSE_THEN “N:num” STRIP_ASSUME_TAC) + >> EXISTS_TAC `\n. if n = 0 then a:real else if n < N then + (i(PRE n) + i(n)) / &2 else b` + >> EXISTS_TAC `SUC N` >> gs[] + >> REPEAT CONJ_TAC + >- ( + GEN_TAC >> gs[] + >> ASM_CASES_TAC “k:num=0” + >- ( + ASM_CASES_TAC “k- ( + ASM_CASES_TAC “SUC k < N” + >> ASM_REWRITE_TAC[REAL_LE_REFL] + >- ( + MATCH_MP_TAC lemma1 >> ASM_REWRITE_TAC[] + >> FIRST_ASSUM(MP_TAC o SPEC `(i:num->real) 0`) + >> CONV_TAC CONTRAPOS_CONV + >> DISCH_THEN(fn th => REWRITE_TAC[th]) + >> EXISTS_TAC `k:num` >> ASM_REWRITE_TAC[] + ) + ) + >> gs[] + ) + >> gs[] >> ASM_CASES_TAC “k- ( + ASM_CASES_TAC “SUC k < N” + >- ( + gs[] >> ‘k = (SUC (PRE k))’ by gs[] + >> ‘i k = i (SUC (PRE k))’ by metis_tac[] + >> ‘i (PRE k) + i k = i k + i (PRE k)’ by real_tac + >> ntac 2 $ pop_assum $ once_rewrite_tac o single + >> gs[] + >> last_assum $ qspec_then ‘PRE k’ assume_tac >> gs[] + >> ‘i (PRE k) < i (SUC k)’ suffices_by real_tac + >> irule REAL_LT_TRANS + >> qexists_tac ‘i (SUC (PRE k))’ >> gs[] + >> ‘(SUC (PRE k)) = k’ by gs[] + >> pop_assum $ once_rewrite_tac o single + >> gs[]) + >> asm_rewrite_tac[] + >> MATCH_MP_TAC lemma3 + >> CONJ_TAC + >- ( ‘k = (SUC (PRE k))’ by gs[] >> metis_tac[] ) + >> FIRST_ASSUM(MP_TAC o SPEC `(i:num->real) k`) + >> CONV_TAC CONTRAPOS_CONV + >> DISCH_THEN(fn th => REWRITE_TAC[th]) + >> EXISTS_TAC `k:num` >> ASM_REWRITE_TAC[] + ) + >> gs[] + ) + >- ( + GEN_TAC >> ASM_CASES_TAC “k:num =0” + >- ( + ASM_REWRITE_TAC[] + >> DISCH_TAC >> gs[] + ) + >> gs[] + >> COND_CASES_TAC >> ASM_REWRITE_TAC[] + >> DISCH_TAC + >> FIRST_ASSUM(MP_TAC o SPEC `(i (PRE k) + i k) / &2`) + >> SUBGOAL_THEN `a:real <= ((i:num->real) (PRE k) + i k) / &2 /\ + (i (PRE k) + i k) / &2 <= b:real` + (fn th => REWRITE_TAC[th]) + >- ( + CONJ_TAC + >- ( + MATCH_MP_TAC lemma1 + >> CONJ_TAC + >- ( + FIRST_ASSUM(MP_TAC o SPEC `(i:num->real) (PRE k)`) + >> CONV_TAC CONTRAPOS_CONV + >> DISCH_THEN(fn th => REWRITE_TAC[th]) + >> EXISTS_TAC `(PRE k):num` + >> gs[] + ) + >> ‘k = (SUC (PRE k))’ by gs[] + >> ‘i k = i (SUC (PRE k))’ by metis_tac[] >> gs[] + ) + >> MATCH_MP_TAC lemma3 + >> CONJ_TAC + >- ( ‘k = (SUC (PRE k))’ by gs[] >> metis_tac[] ) + >> FIRST_ASSUM(MP_TAC o SPEC `(i:num->real) k`) + >> CONV_TAC CONTRAPOS_CONV + >> DISCH_THEN(fn th => REWRITE_TAC[th]) + >> EXISTS_TAC `k:num` >> ASM_REWRITE_TAC[] + ) + >> CONV_TAC CONTRAPOS_CONV >> gs[] >> strip_tac + >> gen_tac >> rewrite_tac[IMP_DISJ_THM] + >> DISJ1_TAC + >> ‘k= SUC(PRE k)’ by gs[] + >> ‘i k = i (SUC (PRE k))’ by metis_tac[] + >> pop_assum $ rewrite_tac o single + >> irule (SIMP_RULE (simpLib.mk_simpset [realSimps.RMULRELNORM_ss]) [] lemma4) >> metis_tac[] + ) + >> GEN_TAC >> gs[] + >> ASM_CASES_TAC “k:num =0” >> ASM_REWRITE_TAC[] + >- ( + ASM_CASES_TAC “N:num=0” + >- ( + EXISTS_TAC `a:real` >> ASM_REWRITE_TAC[REAL_LE_REFL] + >> rw[] + ) + >> ASM_CASES_TAC “N= SUC 0” >> rw[] + >- ( + EXISTS_TAC `(i:num->real) 0` >> gs[] + >> REPEAT CONJ_TAC + >- ( + FIRST_ASSUM(MP_TAC o SPEC `(i:num->real) 0`) + >> CONV_TAC CONTRAPOS_CONV + >> DISCH_THEN(fn th => REWRITE_TAC[th]) + >> EXISTS_TAC `0:num` >> gs[] + ) + >-( + FIRST_ASSUM(MP_TAC o SPEC `(i:num->real) 0`) + >> CONV_TAC CONTRAPOS_CONV + >> DISCH_THEN(fn th => REWRITE_TAC[th]) + >> EXISTS_TAC `0:num` >> gs[] + ) + >> gen_tac >> strip_tac >> gs[] + >> ‘n=0’ by gs[] >> metis_tac[] + ) + >> SUBGOAL_THEN `SUC 0 < N` ASSUME_TAC + >- ( + REWRITE_TAC[GSYM arithmeticTheory.NOT_LESS_EQUAL] + >> gs[] + ) + >> ASM_REWRITE_TAC[] >> EXISTS_TAC `(i:num->real) 0` + >> SUBGOAL_THEN `a:real <= i 0 /\ + (i:num ->real) 0 <= (i 0 + i (SUC 0)) / &2 /\ + (i 0 + i (SUC 0)) / &2 <= b:real` + STRIP_ASSUME_TAC + >- ( + REPEAT CONJ_TAC + >- ( + FIRST_ASSUM(MP_TAC o SPEC `(i:num->real) 0`) + >> CONV_TAC CONTRAPOS_CONV + >> DISCH_THEN(fn th => REWRITE_TAC[th]) + >> EXISTS_TAC `0:num` >> rw[] + ) + >- ( + MATCH_MP_TAC lemma1 + >> ASM_REWRITE_TAC[REAL_LE_REFL] + ) + >> MATCH_MP_TAC lemma3 >> ASM_REWRITE_TAC[] + >> FIRST_ASSUM(MP_TAC o SPEC `(i:num->real) (SUC 0)`) + >> CONV_TAC CONTRAPOS_CONV + >> DISCH_THEN(fn th => REWRITE_TAC[th]) + >> EXISTS_TAC `SUC 0` >> ASM_REWRITE_TAC[] + ) + >> ‘1 = SUC 0’ by gs[] >> pop_assum $ rewrite_tac o single + >> ASM_REWRITE_TAC[] >> conj_tac >- gs[] + >> X_GEN_TAC “x:real” + >> ‘ (poly f x = 0 ∨ EXISTS (λp. poly p x = 0) l) = + EXISTS (\p. poly p x = &0) (CONS f l) ’ by gs[] + >> pop_assum $ rewrite_tac o single + >> STRIP_TAC + >> SUBGOAL_THEN `a <= x /\ x <= b /\ + EXISTS (\p. poly p x = &0) (CONS f l)` + MP_TAC + >- ( + REPEAT CONJ_TAC + >- ASM_REWRITE_TAC[] + >- ( + MATCH_MP_TAC REAL_LE_TRANS + >> EXISTS_TAC `((i:num->real) 0 + i (SUC 0)) / &2` + >> gs[] + ) + >> rw[] + ) + >> first_assum $ qspec_then ‘x’ (fn th => let val (th1, th2) = + EQ_IMP_RULE th in assume_tac th1 end) + >> rpt strip_tac >> qpat_x_assum ‘_ ⇒ ∃ n. n < N ∧ x = i n’ mp_tac + >> impl_tac + >- (rpt conj_tac >> gs[]) + >> DISCH_THEN(X_CHOOSE_THEN “n:num” STRIP_ASSUME_TAC) + >> ASM_REWRITE_TAC[] >> AP_TERM_TAC + >> UNDISCH_TAC `2 * x:real <= (i 0 + i (SUC 0))` + >> ASM_REWRITE_TAC[] + >> FIRST_ASSUM(ASSUME_TAC o MATCH_MP lemma5) + >> gs[] + >> ‘1 = SUC 0’ by gs[] + >> pop_assum $ rewrite_tac o single + >> DISCH_THEN(ANTE_RES_THEN MP_TAC) >> gs[] + ) + >> ASM_CASES_TAC “SUC k < N” + >- ( + SUBGOAL_THEN `k < N:num` ASSUME_TAC + >- gs[] + >> ASM_REWRITE_TAC[] + >> EXISTS_TAC `(i:num->real) k` >> REPEAT CONJ_TAC + >- ( + MATCH_MP_TAC lemma3 + >> CONJ_TAC + >- ( + ‘k = SUC (PRE k)’ by gs[] + >> metis_tac[] + ) + >> gs[] + ) + >- ( MATCH_MP_TAC lemma1 >> gs[] ) + >> X_GEN_TAC “x:real” + >> ‘ (poly f x = 0 ∨ EXISTS (λp. poly p x = 0) l) = + EXISTS (\p. poly p x = &0) (CONS f l) ’ by gs[] + >> pop_assum $ rewrite_tac o single + >> STRIP_TAC + >> SUBGOAL_THEN `a <= x /\ x <= b /\ + EXISTS (\p. poly p x = &0) (CONS f l)` + MP_TAC + >- ( + REPEAT CONJ_TAC + >- ( + MATCH_MP_TAC REAL_LE_TRANS + >> EXISTS_TAC `((i:num->real) (PRE k) + i k) / &2` + >> ASM_REWRITE_TAC[] + >> MATCH_MP_TAC lemma1 >> CONJ_TAC + >- ( + FIRST_ASSUM(MP_TAC o SPEC `(i:num->real) (PRE k)`) + >> CONV_TAC CONTRAPOS_CONV + >> DISCH_THEN(fn th => REWRITE_TAC[th]) + >> EXISTS_TAC `PRE k` >> ASM_REWRITE_TAC[] + >> UNDISCH_TAC `k < N:num` >> gs[] + ) + >> ‘k= SUC (PRE k)’ by gs[] + >> metis_tac[] + ) + >- ( + MATCH_MP_TAC REAL_LE_TRANS + >> EXISTS_TAC `((i:num->real) k + i(SUC k)) / &2` + >> ASM_REWRITE_TAC[] + >> MATCH_MP_TAC lemma3 >> ASM_REWRITE_TAC[] + >> FIRST_ASSUM(MP_TAC o SPEC `(i:num->real) (SUC k)`) + >> CONV_TAC CONTRAPOS_CONV + >> DISCH_THEN(fn th => REWRITE_TAC[th]) + >> EXISTS_TAC `SUC k` >> ASM_REWRITE_TAC[] + ) + >> gs[] + ) + >> first_assum $ qspec_then ‘x’ (fn th => let val (th1, th2) = + EQ_IMP_RULE th in assume_tac th1 end) + >> rpt strip_tac >> qpat_x_assum ‘_ ⇒ ∃ n. n < N ∧ x = i n’ mp_tac + >> impl_tac + >- (rpt conj_tac >> gs[]) + >> DISCH_THEN(X_CHOOSE_THEN “n:num” STRIP_ASSUME_TAC) + >> ASM_REWRITE_TAC[] >> AP_TERM_TAC + >> SUBGOAL_THEN `((i:num->real) (PRE k) + i k) / &2 <= i n /\ + i n <= (i k + i (SUC k)) / &2` + MP_TAC + >- ( + FIRST_ASSUM(UNDISCH_TAC o (fn t => `^t`) o check is_eq o concl) + >> DISCH_THEN SUBST_ALL_TAC >> ASM_REWRITE_TAC[] + ) + >> UNDISCH_TAC `~(k:num = 0)` + >> SPEC_TAC(“k:num”,“m:num”) + >> Induct_on ‘m’ + >- gs[] + >> strip_tac >> ‘PRE (SUC m) = m’ by gs[] + >> pop_assum $ rewrite_tac o single + >> FIRST_ASSUM(MATCH_ACCEPT_TAC o MATCH_MP lemma7) + ) + >> ASM_CASES_TAC “k< N:num” >> ASM_REWRITE_TAC[] + >- ( + EXISTS_TAC `(i:num->real) k` + >> ASM_REWRITE_TAC[CONJ_ASSOC] + >> ‘ ((i (PRE k) + i k) / 2 ≤ i k ∧ i k ≤ b)’ by + ( + CONJ_TAC + >- ( + irule REAL_MIDDLE2 + >> ‘k= SUC (PRE k)’ by gs[] + >> irule REAL_LT_IMP_LE >> metis_tac[] + ) + >> FIRST_ASSUM(MP_TAC o SPEC `(i:num->real) k`) + >> CONV_TAC CONTRAPOS_CONV + >> DISCH_THEN(fn th => REWRITE_TAC[th]) + >> EXISTS_TAC ‘k:num’ >> ASM_REWRITE_TAC[] + ) + >> ASM_REWRITE_TAC[] + >> X_GEN_TAC “x:real” + >> ‘ (poly f x = 0 ∨ EXISTS (λp. poly p x = 0) l) = + EXISTS (\p. poly p x = &0) (CONS f l) ’ by gs[] + >> pop_assum $ rewrite_tac o single + >> STRIP_TAC + >> SUBGOAL_THEN `a <= x /\ x <= b /\ + EXISTS (\p. poly p x = &0) (CONS f l)` + MP_TAC + >- ( + REPEAT CONJ_TAC + >- ( + MATCH_MP_TAC REAL_LE_TRANS + >> EXISTS_TAC `((i:num->real) (PRE k) + i k) / &2` + >> ASM_REWRITE_TAC[] >> MATCH_MP_TAC lemma1 + >> CONJ_TAC + >- ( + FIRST_ASSUM(MP_TAC o SPEC `(i:num->real) (PRE k)`) + >> CONV_TAC CONTRAPOS_CONV + >> DISCH_THEN(fn th => REWRITE_TAC[th]) + >> EXISTS_TAC `PRE k` >> ASM_REWRITE_TAC[] + >> UNDISCH_TAC `k < N:num` >> gs[] + ) + >> ‘k= SUC (PRE k)’ by gs[] >> metis_tac[] + ) + >- ASM_REWRITE_TAC[] + >> metis_tac[] + ) + >> first_assum $ qspec_then ‘x’ (fn th => let val (th1, th2) = + EQ_IMP_RULE th in assume_tac th1 end) + >> rpt strip_tac >> qpat_x_assum ‘_ ⇒ ∃ n. n < N ∧ x = i n’ mp_tac + >> impl_tac + >- (rpt conj_tac >> gs[]) + >> DISCH_THEN(X_CHOOSE_THEN “n:num” STRIP_ASSUME_TAC) + >> ASM_REWRITE_TAC[] >> AP_TERM_TAC + >> FIRST_ASSUM(MP_TAC o SPECL [`n:num`, `PRE k`] o MATCH_MP lemma7) + >> FIRST_ASSUM(UNDISCH_TAC o (fn t => `^t`) o check is_eq o concl) + >> DISCH_THEN SUBST_ALL_TAC + >> UNDISCH_TAC `((i:num->real) (PRE k) + i k) / &2 <= i n` + >> SUBGOAL_THEN `(i:num->real) n <= (i k + i(SUC k)) / &2` MP_TAC + >- ( + MATCH_MP_TAC lemma1 >> ASM_REWRITE_TAC[] + >> FIRST_ASSUM(fn th => REWRITE_TAC[MATCH_MP lemma8 th]) + >> UNDISCH_TAC `n < N:num` + >> UNDISCH_TAC `~(SUC k < N)` >> gs[] + ) + >> UNDISCH_TAC `~(k:num = 0)` >> SPEC_TAC(“k:num”, “m:num”) + >> Induct_on ‘m’ + >- gs[] + >> gs[] >> mesonLib.MESON_TAC[] + ) + >> gs[] >> EXISTS_TAC ‘b:real’ + >> ASM_REWRITE_TAC[REAL_LE_REFL] + >> REWRITE_TAC[CONJ_ASSOC, REAL_LE_ANTISYM] + >> gs[] +QED + + +(* ------------------------------------------------------------------------- *) +(* Basic lemma. *) +(* ------------------------------------------------------------------------- *) + +Theorem STURM_LEMMA_lemma[local] : + ∀ s: real->bool. (s INTER t = EMPTY) ==> FINITE s /\ FINITE t ==> + (CARD (s UNION t) = CARD s + CARD t) +Proof + rpt strip_tac + >> ‘CARD (s ∩ t) = 0’ by gs[CARD_DEF] + >> ‘CARD (s ∪ t) = CARD (s ∪ t) + CARD (s ∩ t)’ by gs[] + >> metis_tac[CARD_UNION] +QED + +Theorem STURM_LEMMA: + !i n. + rsquarefree f /\ + STURM f (diff f) l /\ + (!k. i k <= i (SUC k)) /\ + (!k. k <= n ==> ~(poly f (i k) = &0)) /\ + (!k. ?c. i k <= c /\ + c <= i (SUC k) /\ + (!x. i k <= x /\ + x <= i (SUC k) /\ + EXISTS (\p. poly p x = &0) (CONS f (CONS (diff f) l)) + ==> (x = c))) + ==> FINITE { x | i 0 <= x /\ x <= i n /\ (poly f x = &0) } /\ + (variation (MAP (\p. poly p (i n)) + (CONS f (CONS (diff f) l))) + + CARD { x | i 0 <= x /\ x <= i n /\ (poly f x = &0) } = + variation (MAP (\p. poly p (i 0)) + (CONS f (CONS (diff f) l)))) +Proof + GEN_TAC >> Induct_on ‘n’ + >- ( + STRIP_TAC + >> SUBGOAL_THEN `{x | (i:num->real) 0 <= x /\ x <= (i:num->real) 0 /\ (poly f x = &0)} = {}` + SUBST1_TAC + >- ( + REWRITE_TAC[EXTENSION, NOT_IN_EMPTY] + >> REWRITE_TAC[CONJ_ASSOC, REAL_LE_ANTISYM] + >> UNDISCH_TAC `!(k:num). k <= 0 ==> ~(poly f (i k) = &0)` + >> DISCH_THEN(MP_TAC o SPEC `0`) + >> REWRITE_TAC[arithmeticTheory.LESS_EQ_REFL] >> gs[] + ) + >> CONJ_TAC + >- metis_tac[FINITE_EMPTY] + >> gs[CARD_DEF] + ) +(** second subgoal begins **) + >> STRIP_TAC + >> SUBGOAL_THEN `({x | i 0 <= x /\ x <= i (SUC n) /\ (poly f x = &0)} = + {x | i 0 <= x /\ x <= i n /\ (poly f x = &0)} UNION + {x | i n <= x /\ x <= i (SUC n) /\ (poly f x = &0)}) /\ + ({x | i 0 <= x /\ x <= i n /\ (poly f x = &0)} INTER + {x | i n <= x /\ x <= i (SUC n) /\ (poly f x = &0)} = + EMPTY)` + STRIP_ASSUME_TAC + >- ( + REWRITE_TAC[EXTENSION, IN_INTER, IN_UNION] + >> CONJ_TAC + >- ( + GEN_TAC >> gs[] >> REWRITE_TAC[CONJ_ASSOC] + >> REWRITE_TAC[tautLib.TAUT `a /\ c \/ b /\ c <=> (a \/ b) /\ c`] + >> MATCH_MP_TAC(tautLib.TAUT `(c ==> (a <=> b)) ==> (a /\ c <=> b /\ c)`) + >> DISCH_TAC >> eq_tac + >- ( + strip_tac + >> Cases_on `x <= i n` >> gs[REAL_NOT_LE, REAL_LT_LE] + ) + >> strip_tac THEN gs[] + >- ( + MATCH_MP_TAC REAL_LE_TRANS + >> EXISTS_TAC `(i:num->real) n` >> gs[] + ) + >> MATCH_MP_TAC REAL_LE_TRANS >> EXISTS_TAC `(i:num->real) n` + >> gs[] >> SPEC_TAC(“n:num”, “m:num”) + >> Induct_on ‘m’ + >- gs[] + >> MATCH_MP_TAC REAL_LE_TRANS + >> EXISTS_TAC `(i:num->real) m` >> gs[] + ) + >> GEN_TAC >> REWRITE_TAC[NOT_IN_EMPTY] >> STRIP_TAC + >> UNDISCH_TAC `!k. k <= SUC n ==> ~(poly f (i k) = &0)` >> gs[] + >> EXISTS_TAC ‘n:num’ >> gs[arithmeticTheory.LESS_EQ_SUC_REFL] + >> SUBGOAL_THEN `(i:num->real) n = x` + (fn th => ASM_REWRITE_TAC[th]) + >> ONCE_REWRITE_TAC[GSYM REAL_LE_ANTISYM] + >> ASM_REWRITE_TAC[] + ) + >> FIRST_ASSUM(UNDISCH_TAC o (fn t => `^t`) o check is_imp o concl) + >> ASM_REWRITE_TAC[] + >> SUBGOAL_THEN `!k:num. k <= n ==> ~(poly f (i k) = &0)` ASSUME_TAC + >- ( + GEN_TAC >> DISCH_TAC >> FIRST_ASSUM MATCH_MP_TAC + >> UNDISCH_TAC `k <= n:num` >> gs[] + ) + >> ASM_REWRITE_TAC[] + >> DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) + >> FIRST_ASSUM(X_CHOOSE_THEN “c:real” STRIP_ASSUME_TAC o SPEC `n:num`) + >> MP_TAC(SPECL [`l:(real list)list`, `f:real list`] STURM_COMPONENT) + >> DISCH_THEN(MP_TAC o SPECL [`(i:num->real) n`, `(i:num->real)(SUC n)`]) + >> DISCH_THEN(MP_TAC o SPEC `c:real`) >> ASM_REWRITE_TAC[] + >> SUBGOAL_THEN `~(poly f (i n) = &0) /\ ~(poly f (i (SUC n)) = &0)` + ASSUME_TAC + >- ( + UNDISCH_TAC `!k:num. k <= n ==> ~(poly f (i k) = &0)` + >> DISCH_THEN(K ALL_TAC) >> CONJ_TAC + >> FIRST_ASSUM MATCH_MP_TAC >> rw[] + ) + >> ASM_REWRITE_TAC[] + >> ASM_CASES_TAC “poly f c = &0” >> ASM_REWRITE_TAC[] + >- ( + SUBGOAL_THEN + `FINITE {x | i n <= x /\ x <= i (SUC n) /\ (poly f x = &0)} /\ + (CARD {x | i n <= x /\ x <= i (SUC n) /\ (poly f x = &0)} = 1)` + STRIP_ASSUME_TAC + >- ( + SUBGOAL_THEN `{x | i n <= x /\ x <= i (SUC n) /\ (poly f x = &0)} = + {c}` + SUBST_ALL_TAC + >- ( + REWRITE_TAC[EXTENSION, IN_INSERT, NOT_IN_EMPTY] + >> X_GEN_TAC “x:real” >> EQ_TAC + >- ( + STRIP_TAC + >> ASM_REWRITE_TAC[] >> FIRST_ASSUM MATCH_MP_TAC + >> ASM_REWRITE_TAC[listTheory.EXISTS_DEF] + >> ‘i n ≤ x ∧ x ≤ i (SUC n) ∧ poly f x = 0’ by + ( + pop_assum mp_tac + >> disch_then $ MATCH_ACCEPT_TAC o + SIMP_RULE std_ss [IN_GSPEC_IFF] + ) + >> metis_tac[] + ) + >> strip_tac >> rw[] + ) + >> REWRITE_TAC[FINITE_INSERT] >> rw[CARD_SING, FINITE_EMPTY] + ) + >> rpt strip_tac + >- ( REWRITE_TAC[FINITE_UNION] >> rw[] ) + >> FIRST_ASSUM(MP_TAC o MATCH_MP STURM_LEMMA_lemma) + >> ASM_REWRITE_TAC[] + >> DISCH_THEN SUBST_ALL_TAC + >> REWRITE_TAC[GSYM arithmeticTheory.ADD1, arithmeticTheory.ADD_CLAUSES, + arithmeticTheory.LESS_EQ_MONO] + >> ‘variation (MAP (λp. poly p (i (SUC n))) (f::diff f::l)) + + CARD {x | i 0 ≤ x ∧ x ≤ i n ∧ poly f x = 0} = + CARD {x | i 0 ≤ x ∧ x ≤ i n ∧ poly f x = 0} + + variation (MAP (λp. poly p (i (SUC n))) (f::diff f::l)) + ’ by metis_tac[arithmeticTheory.ADD_COMM] + >> pop_assum $ rewrite_tac o single + >> rewrite_tac[arithmeticTheory.SUC_ADD_SYM] >> metis_tac[] + >> ‘SUC (variation (MAP (λp. poly p (i (SUC n))) (f::diff f::l))) = + variation (MAP (λp. poly p (i n)) (f::diff f::l)) ’ by metis_tac[] + ) + >> SUBGOAL_THEN + `FINITE {x | i n <= x /\ x <= i (SUC n) /\ (poly f x = &0)} /\ + (CARD {x | i n <= x /\ x <= i (SUC n) /\ (poly f x = &0)} = 0)` + STRIP_ASSUME_TAC + >- ( + SUBGOAL_THEN `{x | i n <= x /\ x <= i (SUC n) /\ (poly f x = &0)} = + EMPTY` + SUBST_ALL_TAC + >- ( + REWRITE_TAC[EXTENSION, IN_INSERT, NOT_IN_EMPTY] + >> X_GEN_TAC “x:real” >> STRIP_TAC + >> UNDISCH_TAC `~(poly f c = &0)` + >> SUBGOAL_THEN `x:real = c` (fn th => ASM_REWRITE_TAC[SYM th]) + >- ( + FIRST_ASSUM MATCH_MP_TAC >> ASM_REWRITE_TAC[listTheory.EXISTS_DEF] + >> ‘i n ≤ x ∧ x ≤ i (SUC n) ∧ poly f x = 0’ by + ( + pop_assum mp_tac + >> disch_then $ MATCH_ACCEPT_TAC o SIMP_RULE std_ss [IN_GSPEC_IFF] + ) + >> metis_tac[] + ) + >> ‘i n ≤ x ∧ x ≤ i (SUC n) ∧ poly f x = 0’ by + ( + pop_assum mp_tac + >> disch_then $ MATCH_ACCEPT_TAC o SIMP_RULE std_ss [IN_GSPEC_IFF] + ) + ) + >> rw[] + ) + >> FIRST_ASSUM(MP_TAC o MATCH_MP STURM_LEMMA_lemma) + >> ASM_REWRITE_TAC[] + >> DISCH_THEN SUBST_ALL_TAC >> DISCH_THEN SUBST1_TAC + >> DISCH_THEN(SUBST1_TAC o SYM) + >> REWRITE_TAC[GSYM arithmeticTheory.ADD1, arithmeticTheory.ADD_CLAUSES, + arithmeticTheory.LESS_EQ_MONO] + >> MATCH_MP_TAC FINITE_UNION_IMP >> ASM_REWRITE_TAC[] +QED + +(* ------------------------------------------------------------------------- *) +(* We just need to show that things in Sturm sequence are nontrivial. *) +(* ------------------------------------------------------------------------- *) + +Theorem STURM_NONZERO_LEMMA: + !l f f'. ~(poly f = poly []) /\ STURM f f' l + ==> ~(poly f' = poly []) +Proof + ListConv1.LIST_INDUCT_TAC >> REWRITE_TAC[STURM_def] + >- ( + REPEAT GEN_TAC >> CONV_TAC CONTRAPOS_CONV + >> REWRITE_TAC[DE_MORGAN_THM] + >> DISCH_TAC >> ASM_CASES_TAC “f' poly_divides f” + >> ASM_REWRITE_TAC[] + >> UNDISCH_TAC `f' poly_divides f` >> REWRITE_TAC[poly_divides] + >> DISCH_THEN(CHOOSE_THEN SUBST1_TAC) + >> ASM_REWRITE_TAC[FUN_EQ_THM, POLY_MUL, REAL_MUL_LZERO, poly_def] + >> gs[] + ) + >> REPEAT GEN_TAC >> CONV_TAC CONTRAPOS_CONV + >> REWRITE_TAC[] >> DISCH_TAC >> ASM_REWRITE_TAC[] + >> DISCH_THEN(MP_TAC o el 3 o CONJUNCTS) + >> REWRITE_TAC[arithmeticTheory.NOT_LESS] + >> FIRST_ASSUM(SUBST1_TAC o MATCH_MP DEGREE_ZERO) + >> gs[degree] +QED + +Theorem STURM_NONZERO : + !l f f'. ~(poly f = poly []) /\ STURM f f' l + ==> EVERY (\p. ~(poly p = poly [])) (CONS f' l) +Proof + ListConv1.LIST_INDUCT_TAC >> REWRITE_TAC[STURM_def] + >- ( + REWRITE_TAC[listTheory.EVERY_DEF] >> REPEAT GEN_TAC >> STRIP_TAC + >> gs[] >> MATCH_MP_TAC STURM_NONZERO_LEMMA + >> EXISTS_TAC `[]:(real list)list` + >> EXISTS_TAC `f:real list` >> ASM_REWRITE_TAC[STURM_def] + ) + >> REPEAT STRIP_TAC >> ONCE_REWRITE_TAC[listTheory.EVERY_DEF] + >> ASM_REWRITE_TAC[] + >> SUBGOAL_THEN `~(poly f' = poly [])` ASSUME_TAC + >- ( + DISCH_THEN(SUBST_ALL_TAC o MATCH_MP DEGREE_ZERO) + >> UNDISCH_TAC `degree h < 0` >> gs[] + ) + >> CONJ_TAC + >- metis_tac[] + >> FIRST_ASSUM MATCH_MP_TAC + >> EXISTS_TAC `f':real list` >> metis_tac[] +QED + + +(* ------------------------------------------------------------------------- *) +(* And finally... *) +(* ------------------------------------------------------------------------- *) + +Theorem STURM_STRONG: + !f a b l. + a <= b /\ + ~(poly f a = &0) /\ + ~(poly f b = &0) /\ + rsquarefree f /\ + STURM f (diff f) l + ==> FINITE {x | a <= x /\ x <= b /\ (poly f x = &0)} /\ + (variation + (MAP (\p. poly p b) (CONS f (CONS (diff f) l))) + + CARD {x | a <= x /\ x <= b /\ (poly f x = &0)} = + variation + (MAP (\p. poly p a) (CONS f (CONS (diff f) l)))) +Proof + REPEAT GEN_TAC >> STRIP_TAC + >> SUBGOAL_THEN `EVERY (\p. ~(poly p = poly [])) (CONS (diff f) l)` + ASSUME_TAC + >- ( + MATCH_MP_TAC STURM_NONZERO + >> EXISTS_TAC `f:real list` >> ASM_REWRITE_TAC[] + >> DISCH_THEN SUBST_ALL_TAC + >> UNDISCH_TAC `~(poly [] a = &0)` >> REWRITE_TAC[poly_def] + ) + >> MP_TAC(SPECL [`f:real list`, `CONS (diff f) l`, `a:real`, `b:real`] + POLYS_INTERVAL_SEPARATION) + >> ASM_REWRITE_TAC[] + >> DISCH_THEN(X_CHOOSE_THEN “i:num->real” MP_TAC) + >> DISCH_THEN(X_CHOOSE_THEN “N:num” MP_TAC) + >> DISCH_THEN(CONJUNCTS_THEN2 (SUBST_ALL_TAC o SYM) MP_TAC) + >> DISCH_THEN(CONJUNCTS_THEN2 (SUBST_ALL_TAC o SYM) MP_TAC) + >> STRIP_TAC >> MATCH_MP_TAC STURM_LEMMA + >> ASM_REWRITE_TAC[] +QED + + +Theorem STURM_THM: +!f a b l. + a <= b /\ + ~(poly f a = &0) /\ + ~(poly f b = &0) /\ + rsquarefree f /\ + STURM f (diff f) l + ==> {x | a <= x /\ x <= b /\ (poly f x = &0)} + HAS_SIZE + (variation + (MAP (\p. poly p a) (CONS f (CONS (diff f) l))) - + variation + (MAP (\p. poly p b) (CONS f (CONS (diff f) l)))) +Proof + REPEAT GEN_TAC + >> DISCH_THEN(STRIP_ASSUME_TAC o MATCH_MP STURM_STRONG) + >> ASM_REWRITE_TAC[pred_setTheory.HAS_SIZE] + >> UNDISCH_TAC + `variation (MAP (\p. poly p b) (CONS f (CONS (diff f) l))) + + CARD {x | a <= x /\ x <= b /\ (poly f x = &0)} = + variation (MAP (\p. poly p a) (CONS f (CONS (diff f) l)))` + >> gs[] +QED + +(* ------------------------------------------------------------------------- *) +(* Show that what we get at the end of the Sturm sequence is a GCD. *) +(* ------------------------------------------------------------------------- *) + +Theorem STURM_GCD : +!l k f f'. + STURM f f' (CONS k l) + ==> ?q e r s. (poly f = poly (q * LAST (CONS k l))) /\ + (poly f' = poly (e * LAST (CONS k l))) /\ + (poly (LAST (CONS k l)) = + poly (r * f + s * f')) +Proof + ListConv1.LIST_INDUCT_TAC + >- ( + REPEAT GEN_TAC >> REWRITE_TAC[STURM_def, LAST_DEF] + >> DISCH_THEN(CONJUNCTS_THEN2 MP_TAC STRIP_ASSUME_TAC) + >> DISCH_THEN(X_CHOOSE_THEN “c:real” STRIP_ASSUME_TAC) + >> UNDISCH_TAC `k poly_divides f'` >> REWRITE_TAC[poly_divides] + >> DISCH_THEN(X_CHOOSE_TAC “e:real list”) + >> UNDISCH_TAC `f' poly_divides f + c ## k` + >> REWRITE_TAC[poly_divides] + >> DISCH_THEN(X_CHOOSE_TAC “g:real list”) + >> EXISTS_TAC `e * g + [-c]` + >> EXISTS_TAC `e:real list` + >> EXISTS_TAC `[-(inv(c))]` + >> EXISTS_TAC `inv(c) ## g` + >> SUBGOAL_THEN `poly f = poly ((e * g + [- c]) * k)` ASSUME_TAC + >- ( + REWRITE_TAC[FUN_EQ_THM] >> X_GEN_TAC “x:real” + >> UNDISCH_TAC `poly (f + c ## k) = poly (f' * g)` + >> DISCH_THEN(MP_TAC o SPEC `x:real` o ONCE_REWRITE_RULE[FUN_EQ_THM]) + >> REWRITE_TAC[POLY_ADD, POLY_MUL, POLY_CMUL] + >> ASM_REWRITE_TAC[poly_def, REAL_MUL_RZERO, REAL_ADD_RID, POLY_MUL] + >> REAL_ARITH_TAC + ) + >> ASM_REWRITE_TAC[] + >> ASM_REWRITE_TAC[FUN_EQ_THM, POLY_MUL, REAL_MUL_AC] + >> CONJ_TAC + >- ( X_GEN_TAC “x:real” >> rw[REAL_MUL_SYM] ) + >> X_GEN_TAC “x:real” + >> ASM_REWRITE_TAC[POLY_MUL, POLY_ADD, POLY_CMUL] + >> ASM_REWRITE_TAC[poly_def, REAL_MUL_RZERO, REAL_ADD_RID, POLY_MUL] + >> REWRITE_TAC[REAL_MUL_RNEG, REAL_ADD_LDISTRIB, REAL_ADD_RDISTRIB,REAL_MUL_AC] + >> rewrite_tac[REAL_MUL_LNEG] >> rewrite_tac[REAL_NEGNEG] + >> ‘c⁻¹ * poly e x * poly g x * poly k x = + c⁻¹ * poly g x * poly k x * poly e x’ + by + ( + ‘poly e x * poly g x * poly k x = + poly g x * poly k x * poly e x’ + by + ( + ‘poly e x * poly g x * poly k x = + poly e x * (poly g x * poly k x)’ by + rewrite_tac[GSYM REAL_MUL_ASSOC] + >> pop_assum $ rewrite_tac o single + >> rw [REAL_MUL_SYM] + ) + >> REAL_ARITH_TAC + ) + >> pop_assum $ rewrite_tac o single + >> REWRITE_TAC[REAL_ARITH `(-a + b) + (a:real) = (b:real)`] + >> ONCE_REWRITE_TAC[REAL_MUL_SYM] + >> `inv(c) * (c:real) = &1` by + ( + MATCH_MP_TAC REAL_MUL_LINV + >> UNDISCH_TAC `&0 < c:real` >> REAL_ARITH_TAC + ) + >> gs[] + ) + (* second goal starts here *) + >> REPEAT GEN_TAC >> ONCE_REWRITE_TAC[LAST_DEF] + >> ONCE_REWRITE_TAC[STURM_def] >> REWRITE_TAC[NOT_CONS_NIL] + >> DISCH_THEN(CONJUNCTS_THEN MP_TAC) + >> DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) + >> DISCH_THEN(ANTE_RES_THEN MP_TAC) >> STRIP_TAC + >> DISCH_THEN(X_CHOOSE_THEN “c:real” MP_TAC) + >> DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) + >> REWRITE_TAC[poly_divides] + >> DISCH_THEN(X_CHOOSE_THEN “u:real list” ASSUME_TAC) + >> EXISTS_TAC `q * u + (-c) ## e` + >> EXISTS_TAC `q:real list` + >> EXISTS_TAC `-(inv c) ## s` + >> EXISTS_TAC `r + inv c ## s * u` + >> ASM_REWRITE_TAC[] + >> SUBGOAL_THEN `poly f = poly ((q * u + - c ## e) * LAST (CONS h l))` + ASSUME_TAC + >- ( + UNDISCH_TAC `poly (LAST (CONS h l)) = poly (r * f' + s * k)` + >> DISCH_THEN(K ALL_TAC) + >> REWRITE_TAC[FUN_EQ_THM] >> X_GEN_TAC “x:real” + >> UNDISCH_TAC `poly (f + c ## k) = poly (f' * u)` + >> DISCH_THEN(MP_TAC o SPEC `x:real` o ONCE_REWRITE_RULE[FUN_EQ_THM]) + >> REWRITE_TAC[POLY_ADD, POLY_MUL, POLY_CMUL] + >> ASM_REWRITE_TAC[poly_def, REAL_MUL_RZERO, REAL_ADD_RID, POLY_MUL] + >> REAL_ARITH_TAC + ) + >> ASM_REWRITE_TAC[] + >> UNDISCH_TAC `poly (LAST (CONS h l)) = poly (r * f' + s * k)` + >> DISCH_THEN(K ALL_TAC) + >> REWRITE_TAC[FUN_EQ_THM] >> X_GEN_TAC “x:real” + >> ASM_REWRITE_TAC[POLY_ADD, POLY_MUL, POLY_CMUL, POLY_NEG] + >> REWRITE_TAC[REAL_ADD_LDISTRIB, REAL_ADD_RDISTRIB] + >> REWRITE_TAC[REAL_MUL_LNEG, REAL_MUL_RNEG, REAL_MUL_AC] + >> REWRITE_TAC[REAL_NEG_NEG] + >> ‘c⁻¹ * poly s x * poly q x * poly u x * poly (LAST (h::l)) x = + c⁻¹ * poly s x * poly u x * poly q x * poly (LAST (h::l)) x ’ + by REAL_ARITH_TAC >> pop_assum $ rewrite_tac o single + >> REWRITE_TAC[REAL_ARITH `-a + b + ((c:real) + (a:real)) = (b:real) + c`] + >> ‘ c⁻¹ * poly s x * c * poly e x * poly (LAST (h::l)) x = + poly s x * poly e x * poly (LAST (h::l)) x’ by + ( + ‘c⁻¹ * poly s x * c * poly e x * poly (LAST (h::l)) x= + (inv(c) * c) * poly s x * poly e x * poly (LAST (h::l)) x’ + by REAL_ARITH_TAC >> pop_assum $ rewrite_tac o single + >> `inv(c) * (c:real) = &1` by + ( + MATCH_MP_TAC REAL_MUL_LINV + >> UNDISCH_TAC `&0 < c:real` >> REAL_ARITH_TAC + ) + >> pop_assum $ rewrite_tac o single + >> REAL_ARITH_TAC + ) + >> pop_assum $ rewrite_tac o single + >> REAL_ARITH_TAC +QED + + +(* ------------------------------------------------------------------------- *) +(* Hence avoid a separate check for squarefreeness. *) +(* ------------------------------------------------------------------------- *) + +Theorem STURM_THEOREM : + !f a b l d. + a <= b /\ + ~(poly f a = &0) /\ + ~(poly f b = &0) /\ + ~(poly (diff f) = poly []) /\ + STURM f (diff f) l /\ + ~(l = []) /\ + (LAST l = [d]) /\ + ~(d = &0) + ==> {x | a <= x /\ x <= b /\ (poly f x = &0)} HAS_SIZE + (variation (MAP (\p. poly p a) (CONS f (CONS (diff f) l))) - + variation (MAP (\p. poly p b) (CONS f (CONS (diff f) l)))) +Proof + REPEAT STRIP_TAC >> MATCH_MP_TAC STURM_THM + >> ASM_REWRITE_TAC[] + >> UNDISCH_TAC `LAST l = [d:real]` + >> UNDISCH_TAC `STURM f (diff f) l` + >> UNDISCH_TAC `~(l:(real list)list = [])` + >> SPEC_TAC(“l:(real list)list”, “l:(real list)list”) + >> ListConv1.LIST_INDUCT_TAC + >- REWRITE_TAC[NOT_CONS_NIL] + >> gen_tac >> strip_tac + >> DISCH_THEN(STRIP_ASSUME_TAC o MATCH_MP STURM_GCD) + >> DISCH_THEN SUBST_ALL_TAC + >> MP_TAC(SPECL [`f:real list`, `q:real list`] POLY_SQUAREFREE_DECOMP) + >> DISCH_THEN(MP_TAC o SPECL [`[d:real]`, `e:real list`]) + >> DISCH_THEN(MP_TAC o SPECL [`r:real list`, `s:real list`]) + >> UNDISCH_TAC `~(poly (diff f) = poly [])` + >> DISCH_THEN(fn th => REWRITE_TAC[th]) + >> ASM_REWRITE_TAC[] >> DISCH_THEN(MP_TAC o CONJUNCT1) + >> REWRITE_TAC[rsquarefree] + >> SUBGOAL_THEN `(poly q = poly []) <=> (poly (q * [d]) = poly [])` + ASSUME_TAC + >- ( + ASM_REWRITE_TAC[poly_def, REAL_ENTIRE, FUN_EQ_THM, POLY_MUL] + >> ASM_REWRITE_TAC[REAL_MUL_RZERO, REAL_ADD_RID] + ) + >> ASM_REWRITE_TAC[] + >> MATCH_MP_TAC(tautLib.TAUT `(p ==> (q <=> r)) ==> (p /\ q ==> p /\ r)`) + >> STRIP_TAC + >> SUBGOAL_THEN `!a:real. poly_order a (f:real list) = poly_order a (q:real list)` + (fn th => REWRITE_TAC[th]) + >> X_GEN_TAC “c:real” >> MATCH_MP_TAC EQ_TRANS + >> EXISTS_TAC `poly_order (c:real) ((q:real list) * [d:real])` + >> CONJ_TAC + >- ( MATCH_MP_TAC ORDER_POLY >> ASM_REWRITE_TAC[] ) + >> FIRST_ASSUM(fn th => REWRITE_TAC[MATCH_MP ORDER_MUL th]) + >> SUBGOAL_THEN `poly_order c [d] = 0` (fn th => REWRITE_TAC[th, POLY_ADD_CLAUSES]) + >> MP_TAC(SPECL [`[d:real]`, `c:real`] ORDER_ROOT) + >> ASM_REWRITE_TAC[poly_def, REAL_MUL_RZERO, REAL_ADD_RID] + >> gs[] >> gs[] +QED + + +(* ------------------------------------------------------------------------- *) +(* A conversion for calculating variations. *) +(* ------------------------------------------------------------------------- *) +(* +val VARIATION_CONV = + let + val HO_GEN_REWRITE_CONV = Ho_Rewrite.GEN_REWRITE_CONV + val variation_conv = HO_GEN_REWRITE_CONV I [variation_def] + val cond_conv = HO_GEN_REWRITE_CONV I [COND_CLAUSES] + val sig_conv = HO_GEN_REWRITE_CONV I [SIGN_LEMMA5] + val varrec0_conv = HO_GEN_REWRITE_CONV I [CONJUNCT1 varrec_def] + val varrec1_conv = HO_GEN_REWRITE_CONV I [CONJUNCT2 varrec_def] + in + let + fun VARREC_CONV tm = + varrec0_conv tm + handle HOL_ERR _ => + let + val th1 = (varrec1_conv THENC + RATOR_CONV(LAND_CONV(sig_conv THENC REAL_RAT_REDUCE_CONV)) THENC + cond_conv) tm + val tm1 = rand(concl th1) + in + if is_cond tm1 then + let val th2 = (RATOR_CONV(LAND_CONV REAL_RAT_REDUCE_CONV) THENC + cond_conv THENC + VARREC_CONV) tm1 + in + TRANS th1 th2 + end + else + TRANS th1 (RAND_CONV VARREC_CONV tm1) + end + in + variation_conv THENC VARREC_CONV THENC + DEPTH_CONV NUM_SUC_CONV + end + end; *) + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/transcApproxSemScript.sml b/floatingPoint/tools/dandelion/transcApproxSemScript.sml new file mode 100644 index 0000000000..67dce57b44 --- /dev/null +++ b/floatingPoint/tools/dandelion/transcApproxSemScript.sml @@ -0,0 +1,411 @@ +(** + Define an "approximating" semantics on the elementary functions + of Dandelion. The function approxTransc corresponds to the + function "approxAsPoly" in the paper +**) +open realTheory realLib RealArith transcTheory; +open IntervalArithTheory ErrorValidationTheory sqrtApproxTheory; +open realPolyTheory transcLangTheory approxPolyTheory transcIntvSemTheory approxCompErrTheory; +open bitArithLib; +open preambleDandelion; + +val _ = new_theory "transcApproxSem"; + +val _ = monadsyntax.enable_monadsyntax(); +val _ = monadsyntax.enable_monad "option"; + +Datatype: + approxCfg = + <| steps: num; + |> +End + +Definition errorPropBop_def: + errorPropBop Add (iv1:(real#real)) e1 (iv2:(real#real)) (e2:real) = e1 + e2 ∧ + errorPropBop Sub iv1 e1 iv2 e2 = e1 + e2 ∧ + errorPropBop Mul iv1 e1 iv2 e2 = maxAbs iv1 * e2 + maxAbs iv2 * e1 + e1 * e2 ∧ + errorPropBop Div iv1 e1 iv2 e2 = + maxAbs iv1 * + (1 / + (minAbsFun (widenInterval iv2 e2) * + minAbsFun (widenInterval iv2 e2)) * e2) + + maxAbs (invertInterval iv2) * e1 + + e1 * + (1 / + (minAbsFun (widenInterval iv2 e2) * + minAbsFun (widenInterval iv2 e2)) * e2) +End + +Definition errorPropUop_def: + errorPropUop (Neg:transcLang$unop) (iv:(real#real)) e:real = e ∧ + errorPropUop Inv iv e = + (1 / + (minAbsFun (widenInterval iv e) * + minAbsFun (widenInterval iv e)) * e) +End + +Definition errorPropSinCos_def: + errorPropSinCos cfg iv err = + if approxPolySideCond cfg.steps + then + case approxPoly Cos (0,err) cfg.steps of + | NONE => NONE + | SOME (polyCos, errCos) => + case approxPoly Sin (0,err) cfg.steps of + | NONE => NONE + | SOME (polySin, errSin) => + SOME (abs ((evalPoly polyCos err - errCos) - 1) + evalPoly polySin err + errSin) + else NONE +End + +Definition errorPropFun_def: + errorPropFun Exp cfg (iv:real#real) (err:real) (pWiden:poly) (errPWiden:real) = + SOME ( + errPWiden + (* Exp error *) + (evalPoly pWiden (SND iv) + errPWiden) + * (2 * err)) (* propagated error from f *) + ∧ + errorPropFun Sin cfg (iv:real#real) (err:real) (pWiden:poly) (errPWiden:real) = + (case errorPropSinCos cfg iv err of + | NONE => NONE + | SOME propErr => SOME (errPWiden + propErr)) + ∧ + errorPropFun Cos cfg (iv:real#real) (err:real) (pWiden:poly) (errPWiden:real) = + (case errorPropSinCos cfg iv err of + | NONE => NONE + | SOME propErr => SOME (errPWiden + propErr)) + ∧ + errorPropFun Log cfg iv err pWiden errPWiden = + (if approxPolySideCond cfg.steps ∧ 0 < FST (widenInterval iv err) + then + case approxPoly Log (1 + err / FST (widenInterval iv err), 1 + err / FST (widenInterval iv err)) cfg.steps of + | NONE => NONE + | SOME (p, errP) => + SOME (errPWiden + (evalPoly p (1 + err/FST (widenInterval iv err)) + errP)) + else NONE) + ∧ + errorPropFun _ _ _ _ _ _ = NONE (** TODO **) +End + +Definition isVar_def: + isVar e = case e of |VarAnn iv s => T |_ => F +End + +Definition approxTransc_def: + (** Constants and variables are always exact **) + approxTransc cfg (VarAnn iv s) = SOME (VarAnn 0 s) ∧ + approxTransc cfg (CstAnn iv r) = SOME (CstAnn 0 r) ∧ + (** Binary operators have to propagate errors on the arguments **) + approxTransc cfg (BopAnn iv b e1 e2) = + do + e1Appr <- approxTransc cfg e1; + e2Appr <- approxTransc cfg e2; + assert (b = Div ⇒ + SND (widenInterval (getAnn e2) (getAnn e2Appr)) < 0 ∨ + 0 < FST (widenInterval (getAnn e2) (getAnn e2Appr))); + propError <<- errorPropBop b (getAnn e1) (getAnn e1Appr) (getAnn e2) (getAnn e2Appr); + return (BopAnn propError b e1Appr e2Appr); + od ∧ + approxTransc cfg (UopAnn iv u e) = + do + eAppr <- approxTransc cfg e; + assert (u = Inv ⇒ + SND (widenInterval (getAnn e) (getAnn eAppr)) < 0 ∨ + 0 < FST (widenInterval (getAnn e) (getAnn eAppr))); + propError <<- errorPropUop u (getAnn e) (getAnn eAppr); + return (UopAnn propError u eAppr); + od ∧ + approxTransc cfg (FunAnn iv f e) = + (do + eAppr <- approxTransc cfg e; (* recursive call *) + (if isVar e ∨ getAnn eAppr = 0 then + do + (* approximate polynomial on widened interval *) + (pWiden,errWiden) <- + approxPoly f (widenInterval (getAnn e) (getAnn eAppr) ) cfg.steps; + steps <<- cfg.steps; + assert (approxPolySideCond steps ∧ getAnn eAppr ≤ inv 2 ∧ 0 ≤ getAnn eAppr); + return (PolyAnn errWiden pWiden eAppr); + od + else + do + eAppr <- approxTransc cfg e; (* recursive call *) + (* approximate polynomial on widened interval *) + (pWiden,errWiden) <- + approxPoly f (widenInterval (getAnn e) (getAnn eAppr) ) cfg.steps; + steps <<- cfg.steps; + assert (approxPolySideCond steps ∧ getAnn eAppr ≤ inv 2 ∧ 0 ≤ getAnn eAppr); + fullError <- errorPropFun f cfg (getAnn e) (getAnn eAppr) pWiden errWiden; + return (PolyAnn fullError pWiden eAppr); + od) + od) ∧ + (* We do not support partial approximations for now *) + approxTransc cfg (PolyAnn iv p e) = NONE +End + +Theorem errorPropBop_sound: + ∀ op r11 r12 r21 r22 iv1 iv2 err1 err2. + FST iv1 ≤ r11 ∧ r11 ≤ SND iv1 ∧ + FST iv2 ≤ r12 ∧ r12 ≤ SND iv2 ∧ + (op = Div ⇒ noDivzero (SND iv2) (FST iv2)) ∧ + (op = Div ⇒ let newIv = widenInterval iv2 err2 in noDivzero (SND newIv) (FST newIv)) ∧ + abs (r11 - r21) ≤ err1 ∧ + abs (r12 - r22) ≤ err2 ⇒ + abs (appBop op r11 r12 - appBop op r21 r22) ≤ + errorPropBop op iv1 err1 iv2 err2 +Proof + rpt strip_tac >> Cases_on ‘op’ >> rewrite_tac[errorPropBop_def, appBop_def] + >- ( + real_rw ‘r11 + r12 - (r21 + r22) = r11 - r21 + (r12 - r22)’ + >> transitivity_for ‘abs (r11 - r21) + abs (r12 - r22)’ + >> gs[REAL_ABS_TRIANGLE] + >> irule REAL_LE_ADD2 >> gs[]) + >- ( + real_rw ‘r11 - r12 - (r21 - r22) = r11 - r21 - (r12 - r22)’ + >> gs[real_sub] + >> transitivity_for ‘abs (r11 + - r21) + abs (- (r12 + - r22))’ + >> gs[REAL_ABS_TRIANGLE, real_sub] + >> irule REAL_LE_ADD2 >> gs[]) + >- ( + PairCases_on ‘iv1’ >> PairCases_on ‘iv2’ + >> irule multiplicationErrorBounded >> gs[] + >> conj_tac THENL + [ transitivity_for ‘abs (r11 - r21)’, + transitivity_for ‘abs (r12 - r22)’] + >> gs[ABS_POS]) + >> PairCases_on ‘iv1’ >> PairCases_on ‘iv2’ + >> irule divisionErrorBounded >> gs[] >> rpt conj_tac + >- (irule distance_gives_iv >> qexists_tac ‘r11’ >> gs[contained_def]) + >- (irule distance_gives_iv >> qexists_tac ‘r12’ >> gs[contained_def]) + THENL [ + transitivity_for ‘abs (r11 - r21)’, + transitivity_for ‘abs (r12 - r22)’] + >> gs[ABS_POS] +QED + +Theorem errorPropUop_sound: + ∀ op r1 r2 iv err. + FST iv ≤ r1 ∧ r1 ≤ SND iv ∧ + (op = Inv ⇒ noDivzero (SND iv) (FST iv)) ∧ + (op = Inv ⇒ let newIv = widenInterval iv err in noDivzero (SND newIv) (FST newIv)) ∧ + abs (r1 - r2) ≤ err ⇒ + abs (appUop op r1 - appUop op r2) ≤ + errorPropUop op iv err +Proof + rpt strip_tac >> Cases_on ‘op’ >> rewrite_tac [errorPropUop_def, appUop_def] + >- ( + ‘abs (- r1 - -r2) = abs (r1 - r2)’ suffices_by gs[] + >> real_tac) + >> qspecl_then [‘1’, ‘1’, ‘1’, ‘FST iv’, ‘SND iv’, ‘r1’, ‘1’, ‘r2’, ‘0’, ‘err’] mp_tac divisionErrorBounded + >> gs[] >> impl_tac + >- ( + rpt conj_tac >> gs[] + >- (transitivity_for ‘abs (r1 - r2)’ >> gs[]) + >- gs[contained_def, widenInterval_def] + >> irule distance_gives_iv >> qexists_tac ‘r1’ >> gs[contained_def]) + >> rewrite_tac[REAL_INV_1OVER, EVAL “maxAbs (1,1)”, REAL_MUL_RID] +QED + +Theorem approxTranscFun_sound: + FST iv ≤ x ∧ x ≤ SND iv ∧ + err ≤ inv 2 ∧ + 0 ≤ err ∧ + abs (x - y) ≤ err ∧ + errorPropFun f cfg iv err pWiden errPWiden = SOME fullErr ∧ + (∀ x. FST (widenInterval iv err) ≤ x ∧ x ≤ SND (widenInterval iv err) ⇒ + abs (getFun f x - evalPoly pWiden x) ≤ errPWiden) ⇒ + abs (getFun f x - evalPoly pWiden y) ≤ fullErr +Proof + Cases_on ‘f’ >> rewrite_tac[getFun_def, errorPropFun_def, SOME_11] + >> rpt strip_tac >> rpt VAR_EQ_TAC + >~ [‘abs (exp _ - _)’] + >- ( + irule MCLAURIN_EXP_COMPOSITE_ERR >> gs[PULL_EXISTS] + >> qexists_tac ‘FST iv’ >> gs[] >> conj_tac + >- ( + first_x_assum $ qspec_then ‘SND iv’ mp_tac + >> impl_tac >> gs[widenInterval_def] + >> transitivity_for ‘x’ >> gs[] + >> transitivity_for ‘FST iv’ >> gs[] >> real_tac) + >> first_x_assum $ qspec_then ‘y’ mp_tac >> impl_tac >> gs[] + >> drule $ SIMP_RULE std_ss [AbbrevsTheory.IVlo_def, AbbrevsTheory.IVhi_def, contained_def] distance_gives_iv + >> rpt $ disch_then drule >> gs[]) + >~ [‘abs (sin _ - _)’] + >- ( + gs[CaseEq"option", CaseEq"prod", errorPropSinCos_def] + >> rpt VAR_EQ_TAC + >> irule MCLAURIN_SIN_COMPOSITE_ERR >> gs[PULL_EXISTS] + >> qexists_tac ‘cfg.steps’ >> gs[] + >> first_x_assum $ qspec_then ‘y’ mp_tac >> impl_tac >> gs[] + >> drule $ SIMP_RULE std_ss [AbbrevsTheory.IVlo_def, AbbrevsTheory.IVhi_def, contained_def] distance_gives_iv + >> rpt $ disch_then drule >> gs[]) + >~ [‘abs (cos _ - _)’] + >- ( + gs[CaseEq"option", CaseEq"prod", errorPropSinCos_def] + >> rpt VAR_EQ_TAC + >> irule MCLAURIN_COS_COMPOSITE_ERR >> gs[PULL_EXISTS] + >> qexists_tac ‘cfg.steps’ >> gs[] + >> first_x_assum $ qspec_then ‘y’ mp_tac >> impl_tac >> gs[] + >> drule $ SIMP_RULE std_ss [AbbrevsTheory.IVlo_def, AbbrevsTheory.IVhi_def, contained_def] distance_gives_iv + >> rpt $ disch_then drule >> gs[]) + >~ [‘abs (ln _ - _)’] + >- ( + gs[CaseEq"option", CaseEq"prod"] + >> rpt VAR_EQ_TAC + >> irule MCLAURIN_LN_COMPOSITE_ERR >> gs[PULL_EXISTS] + >> qexists_tac ‘cfg.steps’ >> gs[] + >> first_x_assum $ qspec_then ‘y’ mp_tac >> impl_tac >> gs[] + >> drule $ SIMP_RULE std_ss [AbbrevsTheory.IVlo_def, AbbrevsTheory.IVhi_def, contained_def] distance_gives_iv + >> rpt $ disch_then drule >> gs[] + >> rpt strip_tac + >- ( + irule REAL_LTE_TRANS >> qexists_tac ‘FST iv - err’ + >> gs[widenInterval_def] >> real_tac) + >- ( + irule REAL_LTE_TRANS >> qexists_tac ‘FST iv - err’ + >> gs[widenInterval_def] >> real_tac) + >> gs[min_def] >> cond_cases_tac >> gs[] + >> irule REAL_LE_TRANS >> qexists_tac ‘FST iv - err’ + >> gs[widenInterval_def] >> real_tac) + >~ [‘abs (tan _ - _)’] + >- ( gs[] ) (* by contradiction *) + >~ [‘abs (atan _ - _)’] + >- gs[] (* by contradiction *) + >~ [‘abs (sqrt _ - _)’] + >- ( gs[] ) (* by contradiction *) +QED + +Theorem approxTransc_sound: + ∀ trIVAnn trErrAnn cfg ivenv. + validIVAnnot trIVAnn ivenv ∧ + approxTransc cfg trIVAnn = SOME trErrAnn ⇒ + ∀ cenv. + varsContained cenv ivenv ⇒ + ∃ r1 r2. + interp (erase trIVAnn) cenv = SOME r1 ∧ + interp (erase trErrAnn) cenv = SOME r2 ∧ + abs (r1 - r2) ≤ getAnn trErrAnn +Proof + Induct_on ‘trIVAnn’ >> simp[approxTransc_def, Once validIVAnnot_def] + >> rpt strip_tac + >~ [‘FunAnn iv f e’] (* Transcendental function case *) + >- ( + (* Case distinction for special case *) + Cases_on ‘isVar e ∨ getAnn eAppr = 0’ >> gs[] + >> PairCases_on ‘x’ >> gs[] >> rpt VAR_EQ_TAC + >> qpat_x_assum ‘∀ cenv. varsContained _ _ ⇒ _’ $ + mp_with_then strip_assume_tac ‘varsContained _ _’ + >> gs[erase_def, getAnn_def, GSYM AND_IMP_INTRO] + >> last_x_assum $ mp_with_then assume_tac ‘validIVAnnot _ _’ + >> pop_assum $ mp_with_then assume_tac ‘approxTransc _ _ = _’ + >> pop_assum $ mp_with_then strip_assume_tac ‘varsContained _ _’ + >> gs[interp_def] >> rpt VAR_EQ_TAC + >> qpat_x_assum ‘validIVAnnot e _’ $ mp_then Any assume_tac validIVAnnot_single + >> pop_assum $ mp_with_then strip_assume_tac ‘varsContained _ _’ + >> qpat_x_assum ‘approxPoly _ _ _ = _’ $ mp_then Any assume_tac approxPoly_soundness + >> ‘r = r1’ by gs[] + >> VAR_EQ_TAC + >- ( + pop_assum drule >> disch_then $ qspec_then ‘r’ mp_tac + >> ‘getAnn eAppr = 0’ by + (gs[isVar_def] >> Cases_on ‘e’ >> gs[approxTransc_def] + >> rpt VAR_EQ_TAC >> gs[getAnn_def]) + >> gs[] + >> rpt VAR_EQ_TAC + >> disch_then irule + >> gs[widenInterval_def]) + >- ( + pop_assum drule >> disch_then $ qspec_then ‘r’ mp_tac + >> gs[] + >> rpt VAR_EQ_TAC + >> disch_then irule + >> gs[widenInterval_def]) + >> drule approxTranscFun_sound + >> rpt $ disch_then drule + >> impl_tac + >- (rpt strip_tac >> first_x_assum irule >> gs[]) + >> gs[]) + >~ [‘BopAnn iv op e1 e2’] + >- ( + gs[] >> rpt VAR_EQ_TAC + >> qpat_x_assum ‘∀ cenv. varsContained _ _ ⇒ _’ $ + mp_with_then strip_assume_tac ‘varsContained _ _’ + >> gs[erase_def, getAnn_def, GSYM AND_IMP_INTRO] + >> last_x_assum $ mp_with_then assume_tac ‘validIVAnnot e1 _’ + >> pop_assum $ mpx_with_then assume_tac ‘approxTransc _ trIVAnn = _’ + >> pop_assum $ mp_with_then strip_assume_tac ‘varsContained _ _’ + >> last_x_assum $ mp_with_then assume_tac ‘validIVAnnot e2 _’ + >> pop_assum $ mpx_with_then assume_tac ‘approxTransc _ _ = _’ + >> pop_assum $ mp_with_then strip_assume_tac ‘varsContained _ _’ + >> gs[interp_def] >> rpt VAR_EQ_TAC + >> qpat_x_assum ‘validIVAnnot e1 _’ $ mp_then Any assume_tac validIVAnnot_single + >> pop_assum $ mp_with_then strip_assume_tac ‘varsContained _ _’ + >> qpat_x_assum ‘validIVAnnot e2 _’ $ mp_then Any assume_tac validIVAnnot_single + >> pop_assum $ mp_with_then strip_assume_tac ‘varsContained _ _’ + >> gs[] >> rpt VAR_EQ_TAC >> conj_tac + >- ( + ‘contained r2' (widenInterval (getAnn e2) (getAnn e2Appr))’ + by (irule distance_gives_iv >> qexists_tac ‘r'’ >> gs[contained_def]) + >> gs[contained_def] + >> rpt strip_tac >> CCONTR_TAC >> gs[] >> rpt VAR_EQ_TAC + >> ‘0 < 0’ suffices_by gs[] + >> real_tac) + >> irule errorPropBop_sound >> gs[AbbrevsTheory.noDivzero_def]) + >~ [‘UopAnn iv op e’] + >- ( + gs[] >> rpt VAR_EQ_TAC + >> qpat_x_assum ‘∀ cenv. varsContained _ _ ⇒ _’ $ + mp_with_then strip_assume_tac ‘varsContained _ _’ + >> gs[erase_def, getAnn_def, GSYM AND_IMP_INTRO] + >> last_x_assum $ mp_with_then assume_tac ‘validIVAnnot e _’ + >> pop_assum $ mpx_with_then assume_tac ‘approxTransc _ _ = _’ + >> pop_assum $ mp_with_then strip_assume_tac ‘varsContained _ _’ + >> qpat_x_assum ‘validIVAnnot e _’ $ mp_then Any assume_tac validIVAnnot_single + >> pop_assum $ mp_with_then strip_assume_tac ‘varsContained _ _’ + >> ‘r' = r1’ by gs[] + >> gs[interp_def] >> rpt VAR_EQ_TAC >> conj_tac + >- ( + ‘contained r2 (widenInterval (getAnn e) (getAnn eAppr))’ + by (irule distance_gives_iv >> qexists_tac ‘r'’ >> gs[contained_def]) + >> gs[contained_def] + >> rpt strip_tac >> CCONTR_TAC >> gs[] >> rpt VAR_EQ_TAC + >> ‘0 < 0’ suffices_by gs[] + >> real_tac) + >> irule errorPropUop_sound >> gs[AbbrevsTheory.noDivzero_def]) + >~ [‘CstAnn iv c’] + >- (res_tac >> gs[getAnn_def, erase_def, interp_def]) + >~ [‘VarAnn iv x’] + >> res_tac >> gs[getAnn_def, erase_def, interp_def] +QED + +Definition optionGet_def: + optionGet x = + case x of (SOME x) => x +End + +Theorem optionGet_SOME: + optionGet (SOME x) = x +Proof + gs[optionGet_def] +QED + +Theorem approxTransc_sound_single: + LENGTH ivenv = 1 ∧ + validIVAnnot trIVAnn ivenv ∧ + approxTransc cfg trIVAnn = SOME trErrAnn ⇒ + ∀ x. + FST (SND (HD ivenv)) ≤ x ∧ x ≤ SND (SND (HD ivenv)) ⇒ + abs ((optionGet (interp (erase trIVAnn) [(FST (HD ivenv), x)])) - (optionGet (interp (erase trErrAnn) [(FST (HD ivenv), x)]))) ≤ getAnn trErrAnn +Proof + rpt $ (disch_then strip_assume_tac ORELSE gen_tac) + >> drule approxTransc_sound >> rpt $ disch_then drule + >> disch_then $ qspec_then ‘[(FST (HD ivenv), x)]’ mp_tac + >> impl_tac + >- ( + gs[varsContained_def] >> Cases_on ‘ivenv’ >> gs[LENGTH] + >> rpt VAR_EQ_TAC >> gs[FIND_def, INDEX_FIND_def] + >> Cases_on ‘h’ >> gs[]) + >> disch_then strip_assume_tac >> gs[PULL_EXISTS, optionGet_def] +QED + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/transcIntvSemScript.sml b/floatingPoint/tools/dandelion/transcIntvSemScript.sml new file mode 100644 index 0000000000..36ce6b7bad --- /dev/null +++ b/floatingPoint/tools/dandelion/transcIntvSemScript.sml @@ -0,0 +1,482 @@ +(** + Define an interval semantics on the elementary functions + of Dandelion. The function borrows the definitions and soundness + proof of basic arithmetic from FloVer +**) +open realTheory realLib RealArith transcTheory; +open IntervalArithTheory sqrtApproxTheory IntervalValidationTheory; +open realPolyTheory transcLangTheory mcLaurinApproxTheory approxPolyTheory; +open bitArithLib; +open preambleDandelion; + +val _ = new_theory "transcIntvSem"; + +Definition intvUop_def: + intvUop (Neg:transcLang$unop) iv = negateInterval iv ∧ + intvUop Inv iv = invertInterval iv +End + +Definition intvBop_def: + intvBop (Add:transcLang$binop) iv1 iv2 = addInterval iv1 iv2 ∧ + intvBop Sub iv1 iv2 = subtractInterval iv1 iv2 ∧ + intvBop Mul iv1 iv2 = multInterval iv1 iv2 ∧ + intvBop Div iv1 iv2 = divideInterval iv1 iv2 +End + +Definition evalPolyIntv_def: + evalPolyIntv [] iv = (0,0) ∧ + evalPolyIntv (c::cs) iv = intvBop Add (c,c) (intvBop Mul iv (evalPolyIntv cs iv)) +End + +Definition internalSteps_def: + internalSteps:num = 40 +End + +Definition newtonIters_def: + newtonIters:num = 6 +End + +Theorem pi_le_4: + pi < 4 +Proof + ‘pi / 2 < 2’ by (assume_tac PI2_BOUNDS >> gs[]) + >> gs[real_div] +QED + +(** + compute an interval bound for a transcendental/ HOL4 uncomputable function. + We include sqrt here as it cannot be evaluated in HOL4 directly. + The newton approximation trick is borrowed from FloVer. + As we have to validate the newton approximation afterwards, it may fail + to compute an interval bound thus we return an option here. + In practice, we have not yet encountered a case where 4 iterations where not + sufficient in combination with the multiplications +**) +Definition getFunIv_def: + getFunIv Exp iv = + (let + lbExp = evalPoly (expPoly internalSteps) (FST iv); + ubExp = evalPoly (expPoly internalSteps) (SND iv) + + if iv = (0, inv 2) then expErrSmall internalSteps + else expErrBig (clg (abs (SND iv) * 2)) internalSteps; + in + SOME (lbExp, ubExp)) ∧ + getFunIv Sin iv = SOME (-1, 1) ∧ + getFunIv Cos iv = SOME (-1, 1) ∧ + getFunIv Tan iv = NONE ∧ + (** Very coarse, but this is as good as it gets with the rough bounds on pi/2 **) + getFunIv Atn iv = SOME (-2, 2) ∧ + getFunIv Sqrt iv = + (* we do a newton approximation of the lower and upper bounds, + 0 < FST iv has to be checked before *) + ( let sqrtLo = newton newtonIters (FST iv * 0.99) (IVlo iv * 0.99); + sqrtHi = newton newtonIters (SND iv * 1.01) (SND iv * 1.01); + newIV = (sqrtLo, sqrtHi) + in + if (validate_newton_down sqrtLo (FST iv) ∧ + validate_newton_up sqrtHi (SND iv)) then + SOME newIV + else NONE)∧ + getFunIv Log iv = + (let + lbLog = evalPoly (compose (logPoly (internalSteps+1)) [-1;1]) (FST iv); + ubLog = evalPoly (compose (logPoly (internalSteps + 1)) [-1;1]) (SND iv) + + logErr iv (internalSteps+1); + in + SOME (lbLog, ubLog)) +End + +Definition interpIntv_def: + interpIntv (Var x) (env:(string#(real#real)) list) = + do xv <- FIND (λ (y, iv). y = x) env; + return (VarAnn (SND xv) x); + od ∧ + interpIntv (Cst c) env = SOME (CstAnn (c,c) c) ∧ + interpIntv (Uop uop t) env = + do r <- interpIntv t env; + assert ((~ (uop = Inv)) ∨ (SND (getAnn r) < 0 ∨ 0 < FST (getAnn r) )); + return (UopAnn (intvUop uop (getAnn r)) uop r) + od ∧ + interpIntv (Bop bop t1 t2) env = + do + r1 <- interpIntv t1 env; + r2 <- interpIntv t2 env; + iv1 <<- getAnn r1; + iv2 <<- getAnn r2; + assert (bop = Div ⇒ (SND iv2 < 0 ∨ 0 < FST iv2)); + return (BopAnn (intvBop bop iv1 iv2) bop r1 r2); + od ∧ + interpIntv (Fun s t) env = + do + r <- interpIntv t env; + iv <<- getAnn r; + (* Sqrt defined for positive values only *) + assert ((~ (s = Sqrt)) ∨ (0 < FST iv)); + (* Tan cannot be done at 0 because we approximate it with sin x/cos x *) + assert ((~ (s = Tan)) ∨ (SND iv < 0 ∨ 0 < FST iv)); + (* Log defined for positive values only *) + assert ((~ (s = Log)) ∨ (1 < FST iv)); + ivRes <- getFunIv s iv; + return (FunAnn ivRes s r); + od ∧ + interpIntv (Poly p t) env = + do + r <- interpIntv t env; + iv <<- getAnn r; + return (PolyAnn (evalPolyIntv p iv) p r); + od +End + +Definition varsContained_def: + varsContained (cenv:(string#real) list) (ivenv:(string#(real#real)) list) = + ∀ x xiv. + FIND (λ (y,r). y = x) ivenv = SOME xiv ⇒ + ∃ xr. + FIND (λ (y,r). y = x) cenv = SOME xr ∧ + FST (SND xiv) ≤ SND xr ∧ SND xr ≤ SND (SND xiv) +End + +Theorem evalPolyIntv_sound: + ∀ p x iv. + FST iv ≤ x ∧ + x ≤ SND iv ⇒ + FST (evalPolyIntv p iv) ≤ evalPoly p x ∧ + evalPoly p x ≤ SND (evalPolyIntv p iv) +Proof + Induct_on ‘p’ >> gs[evalPolyIntv_def, evalPoly_def] + >> rpt strip_tac + >> first_x_assum $ drule_then $ drule_then assume_tac + >> ‘contained (evalPoly p x) (evalPolyIntv p iv)’ by gs[contained_def] + >> ‘contained x iv’ by gs[contained_def] + >> pop_assum $ mp_then Any mp_tac interval_multiplication_valid + >> disch_then (fn th => pop_assum $ mp_then Any mp_tac th) + >> qspec_then ‘h’ (assume_tac o SIMP_RULE std_ss [pointInterval_def]) validPointInterval + >> pop_assum $ mp_then Any mp_tac (SIMP_RULE std_ss [validIntervalAdd_def] interval_addition_valid) + >> disch_then (fn th => disch_then $ mp_then Any mp_tac th) + >> strip_tac >> gs[contained_def, intvBop_def] +QED + +Definition validIVAnnot_def: + validIVAnnot tAnn ivenv = + ((∀ cenv. + varsContained cenv ivenv ⇒ + ∃ r. interp (erase tAnn) cenv = SOME r ∧ + FST (getAnn tAnn) ≤ r ∧ + r ≤ SND (getAnn tAnn)) ∧ + (case tAnn of + | CstAnn _ _ => T + | VarAnn _ _ => T + | UopAnn _ u e => + (u = Inv ⇒ SND (getAnn e) < 0 ∨ 0 < FST (getAnn e)) ∧ + validIVAnnot e ivenv + | BopAnn _ b e1 e2 => + (b = Div ⇒ (SND (getAnn e2) < 0 ∨ 0 < FST (getAnn e2))) ∧ + validIVAnnot e1 ivenv ∧ validIVAnnot e2 ivenv + | FunAnn _ _ e => validIVAnnot e ivenv + | PolyAnn _ _ e => validIVAnnot e ivenv)) +End + +Theorem validIVAnnot_single: + validIVAnnot tAnn ivenv ⇒ + ∀ cenv. + varsContained cenv ivenv ⇒ + ∃ r. interp (erase tAnn) cenv = SOME r ∧ + FST (getAnn tAnn) ≤ r ∧ + r ≤ SND (getAnn tAnn) +Proof + gs[Once validIVAnnot_def] >> metis_tac[] +QED + +Theorem interpIntv_sound: + ∀ t ivenv tAnn. + interpIntv t ivenv = SOME tAnn ⇒ + validIVAnnot tAnn ivenv +Proof + Induct_on ‘t’ >> simp[interpIntv_def, Once validIVAnnot_def] + >> rpt strip_tac + >- ( + last_x_assum $ mpx_with_then assume_tac ‘interpIntv t ivenv = _’ + >> mp_with_then (mpx_with_then strip_assume_tac ‘varsContained _ _’) ‘validIVAnnot r _’ validIVAnnot_single + >> Cases_on ‘t0’ >> gs[getFun_def, getFunIv_def] + >> rpt VAR_EQ_TAC >> gs[SIN_BOUNDS, COS_BOUNDS, erase_def, getAnn_def, interp_def, getFun_def] + (* exp *) + >- ( + conj_tac + (* lower bound *) + >- ( + irule REAL_LE_TRANS >> qexists_tac ‘exp (FST (getAnn r))’ + >> gs[EXP_MONO_LE] + >> qspecl_then [‘FST (getAnn r)’, ‘internalSteps’] strip_assume_tac MCLAURIN_EXP_LE + >> pop_assum $ rewrite_tac o single + >> gs[exp_sum_to_poly] + >> irule REAL_LE_MUL + >> gs[POW_POS, internalSteps_def] + >> irule REAL_LE_MUL + >> gs[EXP_POS_LE]) + (* upper bound *) + >> irule REAL_LE_TRANS >> qexists_tac ‘exp (SND (getAnn r))’ + >> gs[EXP_MONO_LE] + >> qspecl_then [‘SND (getAnn r)’, ‘internalSteps’] strip_assume_tac MCLAURIN_EXP_LE + >> pop_assum $ rewrite_tac o single + >> gs[exp_sum_to_poly] + >> qmatch_goalsub_abbrev_tac ‘exp_err ≤ _’ + >> irule REAL_LE_TRANS >> qexists_tac ‘abs exp_err’ >> gs[ABS_LE] + >> unabbrev_all_tac + >> Cases_on ‘getAnn r = (0, inv 2)’ + >> asm_rewrite_tac[expErrSmall_def, GSYM real_div] + >- ( + irule exp_remainder_bounded_small + >> Cases_on ‘r’ >> gs[internalSteps_def] + >> gs[abs] >> every_case_tac >> real_tac) + >> asm_rewrite_tac[expErrBig_def] + >> irule exp_remainder_bounded_big + >> qmatch_goalsub_abbrev_tac ‘abs (SND (getAnn r)) ≤ upExp’ + >> ‘abs (SND (getAnn r)) ≤ upExp’ + by ( + unabbrev_all_tac + >> cond_cases_tac >> gs[] + >- (pop_assum $ rewrite_tac o single o GSYM >> gs[]) + >> irule REAL_LE_TRANS >> qexists_tac ‘&clg (2 * abs (SND (getAnn r)))’ + >> gs[LE_NUM_CEILING]) + >> rpt conj_tac >> TRY( gs[internalSteps_def] >> NO_TAC) + >> irule REAL_LE_TRANS + >> qexists_tac ‘abs t’ >> gs[ABS_LE] + >> irule REAL_LE_TRANS >> qexists_tac ‘abs (SND (getAnn r))’ >> gs[]) + (* atn *) + >- ( + rpt conj_tac + >> qspec_then ‘r'’ strip_assume_tac ATN_BOUNDS + >> strip_assume_tac PI2_BOUNDS + >> irule REAL_LE_TRANS + >- ( + qexists_tac ‘- (pi/2)’ >> conj_tac + >> real_tac) + >> qexists_tac ‘pi/2’ >> conj_tac + >> real_tac) + (* sqrt *) + >- ( first_x_assum $ mp_then Any mp_tac validate_newton_lb_valid + >> impl_tac >> gs[] + >- ( + reverse conj_tac >- real_tac + >> irule newton_method_pos >> conj_tac + >> irule REAL_LE_MUL >> gs[] >> real_tac) + >> first_x_assum $ mp_then Any mp_tac validate_newton_ub_valid + >> impl_tac >> gs[] + >- ( + reverse conj_tac >- real_tac + >> irule newton_method_pos >> conj_tac + >> irule REAL_LE_MUL >> gs[] >> real_tac) + >> rpt strip_tac + >> irule REAL_LE_TRANS + THENL [ + qexists_tac ‘sqrt (FST (getAnn r))’, + qexists_tac ‘sqrt (SND (getAnn r))’] + >> gs[] + >> irule SQRT_MONO_LE >> real_tac) + (* ln *) + >> conj_tac + (* lower bound *) + >- ( + irule REAL_LE_TRANS >> qexists_tac ‘ln (FST (getAnn r))’ + >> ‘0 < r'’ by real_tac + >> ‘0 < FST (getAnn r)’ by real_tac + >> gs[LN_MONO_LE] + >> qspecl_then [‘FST (getAnn r) - 1 ’, ‘internalSteps+1’] mp_tac MCLAURIN_LN_POS + >> impl_tac >- ( gs[internalSteps_def] >> real_tac ) + >> strip_tac + >> ‘1 + (FST (getAnn r) − 1) = FST (getAnn r)’ by real_tac + >> ‘0 < internalSteps+1’ by gs[internalSteps_def] + >> gs[log_sum_to_poly_indexshift] + >> irule REAL_LE_MUL + >> conj_tac + >- ( irule REAL_LE_MUL + >> conj_tac + >- gs[internalSteps_def] + >> ‘1+t ≠ 0’ by real_tac + >> gs[POW_INV] + >> DISJ1_TAC >> real_tac + ) + >> irule POW_POS >> real_tac) + (* upper bound *) + >> irule REAL_LE_TRANS >> qexists_tac ‘ln (SND (getAnn r))’ + >> ‘0 < r'’ by real_tac + >> ‘0 < SND (getAnn r)’ by real_tac + >> gs[LN_MONO_LE] + >> qspecl_then [‘SND (getAnn r) - 1 ’, ‘internalSteps+1’] mp_tac MCLAURIN_LN_POS + >> impl_tac >- ( gs[internalSteps_def] >> real_tac ) + >> strip_tac + >> pop_assum mp_tac + >> ‘1 + (SND (getAnn r) − 1) = SND (getAnn r)’ by real_tac + >> asm_rewrite_tac[] + >> disch_then $ once_rewrite_tac o single + >> ‘0 < internalSteps+1’ by gs[internalSteps_def] + >> pop_assum $ mp_then Any mp_tac log_sum_to_poly_indexshift + >> disch_then $ once_rewrite_tac o single + >> irule REAL_LE_LADD_IMP + >> rewrite_tac[logErr_def, internalSteps_def] + >> rewrite_tac[EVAL“-1 pow SUC (40 + 1)”, REAL_MUL_LID, real_div, ABS_MUL, GSYM POW_ABS] + >> irule REAL_LE_MUL2 + >> gs[] >> rpt conj_tac + >- (irule POW_LE >> conj_tac >> real_tac) + >- (rewrite_tac[abs] >> gs[REAL_INV_MUL'] + >> ‘inv (1 + t) ≤ 1’ by ( + once_rewrite_tac[GSYM REAL_INV1] + >> irule REAL_LE_INV2 >> gs[] >> real_tac) + >> once_rewrite_tac [GSYM $ EVAL “1 pow 41”] + >> irule POW_LE >> gs[] + >> real_tac) + >- ( real_tac ) + >> real_tac) + >- (rpt VAR_EQ_TAC >> gs[]) + >- ( + last_x_assum $ mpx_with_then assume_tac ‘interpIntv _ _ = _’ + >> mp_with_then (mpx_with_then strip_assume_tac ‘varsContained cenv ivenv’) ‘validIVAnnot _ _’ validIVAnnot_single + >> rpt VAR_EQ_TAC >> gs[erase_def, getAnn_def, interp_def] + >> drule_then drule evalPolyIntv_sound + >> disch_then $ qspec_then ‘l’ assume_tac + >> gs[]) + >- (rpt VAR_EQ_TAC >> gs[]) + >- ( + rpt VAR_EQ_TAC >> gs[getAnn_def, erase_def, interp_def, PULL_EXISTS] + >> last_x_assum $ mpx_with_then assume_tac ‘interpIntv t _ = _’ + >> last_x_assum $ mpx_with_then assume_tac ‘interpIntv t' _ = _’ + >> ntac 2 (pop_assum $ mp_then Any (mp_with_then mp_tac ‘varsContained cenv ivenv’) validIVAnnot_single) + >> rpt strip_tac >> gs[] + >> Cases_on ‘b’ >> gs[intvBop_def] + >- ( + qspecl_then [‘getAnn r1’, ‘getAnn r2’] mp_tac interval_addition_valid + >> gs[validIntervalAdd_def, contained_def, appBop_def] + >> rpt $ disch_then drule) + >- ( + qspecl_then [‘getAnn r1’, ‘getAnn r2’] mp_tac interval_subtraction_valid + >> gs[validIntervalSub_def, contained_def, appBop_def] + >> rpt $ disch_then drule) + >- ( + qspecl_then [‘getAnn r1’, ‘getAnn r2’] mp_tac interval_multiplication_valid + >> gs[contained_def, appBop_def]) + >> conj_tac + >> TRY (qspecl_then [‘getAnn r1’, ‘getAnn r2’] mp_tac interval_division_valid + >> gs[contained_def, appBop_def] >> NO_TAC) + >> CCONTR_TAC >> gs[] >> rpt VAR_EQ_TAC + >> ‘0 < 0’ suffices_by gs[] >> real_tac) + >- (rpt VAR_EQ_TAC >> gs[]) + >- ( + rpt VAR_EQ_TAC >> gs[getAnn_def, erase_def, interp_def, PULL_EXISTS] + >> last_x_assum $ mpx_with_then assume_tac ‘interpIntv t _ = _’ + >> pop_assum $ mp_then Any (mp_with_then strip_assume_tac ‘varsContained cenv ivenv’) validIVAnnot_single + >> Cases_on ‘u’ >> gs[interp_def, intvUop_def, appUop_def] + >- ( + qspec_then ‘getAnn r’ mp_tac interval_negation_valid + >> gs[contained_def]) + >> qspec_then ‘getAnn r’ assume_tac interval_inversion_valid + >> gs[contained_def] + >> CCONTR_TAC >> gs[] >> rpt VAR_EQ_TAC + >> ‘0 < 0’ suffices_by gs[] >> real_tac) + >> rpt VAR_EQ_TAC + >> gs[interp_def, erase_def, getAnn_def, varsContained_def, PULL_EXISTS] +QED + +Definition sqrtReplace_def: + sqrtReplace (VarAnn iv x) = SOME (Var x) ∧ + sqrtReplace (CstAnn iv c) = SOME (Cst c) ∧ + sqrtReplace (UopAnn iv u e) = + do + eRepl <- sqrtReplace e; + return (Uop u eRepl); + od ∧ + sqrtReplace (BopAnn iv b e1 e2) = + do + e1Repl <- sqrtReplace e1; + e2Repl <- sqrtReplace e2; + return (Bop b e1Repl e2Repl); + od ∧ + sqrtReplace (PolyAnn iv p e)= + do + eRepl <- sqrtReplace e; + return (Poly p eRepl); + od ∧ + sqrtReplace ((FunAnn iv f e):(real#real)approxAnn) = + do + eRepl <- sqrtReplace e; + if (f = Sqrt ∧ 1 < FST (getAnn e) ∧ 1 < SND (getAnn e)) + then return (Fun Exp (Bop Mul (Fun Log eRepl) (Cst (inv 2)))) + else return (Fun f eRepl) + od +End + +(** TODO Make this an equivalence **) +Theorem sqrtReplace_sound: + ∀ tr tr' r ivenv cenv. + sqrtReplace tr = SOME tr'∧ + validIVAnnot tr ivenv ∧ + interp (erase tr) cenv = SOME r ∧ + varsContained cenv ivenv ⇒ + interp tr' cenv = SOME r +Proof + Induct_on ‘tr’ >> simp[sqrtReplace_def, SimpL“$==>”, erase_def, interp_def, Once validIVAnnot_def] + >> rpt strip_tac + >> first_x_assum $ mp_with_then strip_assume_tac ‘varsContained _ _’ + >- ( + qpat_x_assum ‘_ = SOME tr'’ mp_tac + >> cond_cases_tac >> gs[] >> strip_tac + >> rpt VAR_EQ_TAC + >- ( + last_x_assum $ drule_then drule >> gs[] + >> strip_tac + >> simp[interp_def, getFun_def, appBop_def] + >> mpx_with_then assume_tac ‘validIVAnnot tr ivenv’ validIVAnnot_single + >> pop_assum $ drule_then strip_assume_tac + >> gs[] >> VAR_EQ_TAC + >> ‘1 < r’ by real_tac + >> ‘0 < r’ by real_tac + >> mpx_with_then assume_tac ‘0 < r’ SQRT_EXPLN_GENERAL + >> gs[] + >> ‘1/2 * ln r = ln r / 2’ by gs[] + >> pop_assum $ rewrite_tac o single) + >> last_x_assum $ drule_then drule >> gs[] + >> strip_tac >> gs[interp_def]) + >> rpt (first_x_assum $ dxrule_then $ dxrule_then dxrule >> gs[] + >> strip_tac) + >> rpt VAR_EQ_TAC + >> gs[interp_def, erase_def] +QED + +(** Version computing bounds: + +Definition sqrtReplace_def: + sqrtReplace (VarAnn iv x) = SOME (VarAnn iv x) ∧ + sqrtReplace (CstAnn iv c) = SOME (CstAnn iv c) ∧ + sqrtReplace (UopAnn iv u e) = + do + eRepl <- sqrtReplace e; + return (UopAnn iv u eRepl); + od ∧ + sqrtReplace (BopAnn iv b e1 e2) = + do + e1Repl <- sqrtReplace e1; + e2Repl <- sqrtReplace e2; + return (BopAnn iv b e1Repl e2Repl); + od ∧ + sqrtReplace (PolyAnn iv p e)= + do + eRepl <- sqrtReplace e; + return (PolyAnn iv p eRepl); + od ∧ + sqrtReplace ((FunAnn iv f e):(real#real)approxAnn) = + do + eRepl <- sqrtReplace e; + if (f = Sqrt ∧ 1 < FST (getAnn e) ∧ 1 < SND (getAnn e)) + then + do + assert (1 < FST (getAnn eRepl)); + ivLog <- getFunIv Log iv; + ivMul <<- intvBop Mul ivLog (inv 2, inv 2); + ivExp <- getFunIv Exp ivMul; + return (FunAnn ivExp Exp (BopAnn ivMul Mul (FunAnn ivLog Log eRepl) (CstAnn (inv 2, inv 2) (inv 2)))); + od + else return (FunAnn iv f eRepl) + od +End +**) + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/transcLangScript.sml b/floatingPoint/tools/dandelion/transcLangScript.sml new file mode 100644 index 0000000000..2f25d6870b --- /dev/null +++ b/floatingPoint/tools/dandelion/transcLangScript.sml @@ -0,0 +1,134 @@ +(** + Define a simple "language" for describing elementary + functions. For now we only allow combinations, i.e. + exp (sin (cos ...) but no additional operators like +,-,*,/ +**) +open realPolyTheory; +open preambleDandelion; + +val _ = new_theory "transcLang"; + +val _ = monadsyntax.enable_monadsyntax(); +val _ = monadsyntax.enable_monad "option"; + +Datatype: + binop = Add | Sub | Mul | Div +End + +Datatype: + unop = Neg | Inv +End + +(* Log = natural logarithm *) +Datatype: + trFun = Exp | Sin | Cos | Tan | Atn | Sqrt | Log +End + +Datatype: + transc = + Fun trFun transc + | Poly poly transc + | Bop binop transc transc + | Uop unop transc + | Cst real + | Var string +End + +Datatype: + approxAnn = + FunAnn 'a trFun approxAnn + | PolyAnn 'a poly approxAnn + | BopAnn 'a binop approxAnn approxAnn + | UopAnn 'a unop approxAnn + | CstAnn 'a real + | VarAnn 'a string +End + +Definition getAnn_def: + getAnn (FunAnn a _ _) = a ∧ + getAnn (PolyAnn a _ _) = a ∧ + getAnn (BopAnn a _ _ _) = a ∧ + getAnn (UopAnn a _ _) = a ∧ + getAnn (CstAnn a _) = a ∧ + getAnn (VarAnn a _) = a +End + +Definition erase_def: + erase (FunAnn _ f e) = Fun f (erase e) ∧ + erase (PolyAnn _ p e) = Poly p (erase e) ∧ + erase (BopAnn _ b e1 e2) = Bop b (erase e1) (erase e2) ∧ + erase (UopAnn _ u e) = Uop u (erase e) ∧ + erase (CstAnn _ r) = Cst r ∧ + erase (VarAnn _ s) = Var s +End + + +Definition getFun_def: + getFun Exp = exp ∧ + getFun Sin = sin ∧ + getFun Cos = cos ∧ + getFun Tan = tan ∧ + getFun Atn = atn ∧ + getFun Sqrt = sqrt ∧ + getFun Log = ln +End + +Definition appUop_def: + appUop Neg r = - r ∧ + appUop Inv r = inv r +End + +Definition appBop_def: + appBop Add = realax$real_add ∧ + appBop Sub = $- ∧ + appBop Mul = $* ∧ + appBop Div = $/ +End + +Definition interp_def: + interp (Var x) env = + do v <- FIND (λ (y,r). y = x) env; + return (SND v); + od ∧ + interp (Cst c) env = SOME c ∧ + interp (Uop uop t) env = + do + r <- interp t env; + assert (uop = Inv ⇒ r ≠ 0); + return (appUop uop r) + od ∧ + interp (Bop bop t1 t2) env = + do + r1 <- interp t1 env; + r2 <- interp t2 env; + assert (bop = Div ⇒ r2 ≠ 0); + return (appBop bop r1 r2); + od ∧ + interp (Fun s t) env = + do + r <- interp t env; + return ((getFun s) r); + od ∧ + interp (Poly p t) env = + do + r <- interp t env; + return (evalPoly p r) + od +End + +Datatype: + transcProg = + Let string transc transcProg + | Ret transc +End + +Definition interpProg_def: + interpProg (Let x e p) env = + do + r <- interp e env; + interpProg p ((x, r)::env) + od ∧ + interpProg (Ret e) env = interp e env +End + +val _ = export_theory(); diff --git a/floatingPoint/tools/dandelion/transcReflectScript.sml b/floatingPoint/tools/dandelion/transcReflectScript.sml new file mode 100644 index 0000000000..f51e2a7727 --- /dev/null +++ b/floatingPoint/tools/dandelion/transcReflectScript.sml @@ -0,0 +1,87 @@ +(** + Simple reflection function translating elements of the deeply + embedded transc datatype into the polynomials defined in + realPolyScript.sml +**) +open realPolyTheory realPolyProofsTheory transcLangTheory; +open preambleDandelion; + +val _ = new_theory"transcReflect"; + +Definition reflectToPoly_def: + reflectToPoly (Var x) y = (if x = y then SOME (var 1) else NONE) ∧ + reflectToPoly (Cst c) y = SOME (cst c) ∧ + reflectToPoly (Uop u e) y = + (case reflectToPoly e y of + | NONE => NONE + | SOME p => + if u ≠ Inv then SOME (poly_neg p) + else NONE) + ∧ + reflectToPoly (Bop b e1 e2) y = + (case reflectToPoly e1 y of + | NONE => NONE + | SOME p1 => + case reflectToPoly e2 y of + | NONE => NONE + | SOME p2 => + if b ≠ Div then + (case b of + | Add => SOME (poly_add p1 p2) + | Sub => SOME (poly_sub p1 p2) + | Mul => SOME (poly_mul p1 p2)) + else NONE) + ∧ + reflectToPoly (Poly p e) y = + (case reflectToPoly e y of + | NONE => NONE + | SOME p1 => SOME (compose p p1)) + ∧ + reflectToPoly (Fun _ _) _ = NONE +End + +Theorem reflectSemEq: + ∀ tr p x xv v. + reflectToPoly tr x = SOME p ∧ + interp tr [(x,xv)] = SOME v ⇒ + polyEvalsTo p xv v +Proof + Induct_on ‘tr’ >> gs[reflectToPoly_def, interp_def, polyEvalsTo_def, CaseEq"option"] + >> rpt strip_tac + >- ( + first_x_assum $ drule_then drule + >> rpt strip_tac >> rpt VAR_EQ_TAC + >> gs[compose_correct]) + >- ( + ntac 2 $ last_x_assum $ drule_then drule + >> rpt strip_tac >> rpt VAR_EQ_TAC + >> Cases_on ‘b’ >> gs[] >> rpt VAR_EQ_TAC + >> gs[appBop_def, eval_simps]) + >- ( + last_x_assum $ drule_then drule + >> rpt strip_tac >> rpt VAR_EQ_TAC + >> Cases_on ‘u’ >> gs[appUop_def, eval_simps]) + >- ( + gs[cst_def] >> IF_CASES_TAC + >> gs[evalPoly_def]) + >> ‘1 = SUC 0’ by gs[] + >> pop_assum $ rewrite_tac o single + >> gs[var_def, evalPoly_def, FIND_def, INDEX_FIND_def] + >> rpt VAR_EQ_TAC >> gs[] +QED + +Theorem reflectSemEquiv: + reflectToPoly tr x = SOME p ⇒ + interp tr [(x, xv)] = SOME (evalPoly p xv) +Proof + reverse $ Cases_on ‘interp tr [(x, xv)]’ >> rpt strip_tac >> gs[] + >- ( + drule reflectSemEq >> disch_then drule + >> gs[polyEvalsTo_def]) + >> rpt $ pop_assum mp_tac + >> SPEC_TAC (“p:real list”, “p:real list”) + >> Induct_on ‘tr’ >> gs[interp_def, reflectToPoly_def] + >> rpt strip_tac >> res_tac >> gs[FIND_def, INDEX_FIND_def, CaseEq"option"] +QED + +val _ = export_theory(); diff --git a/icing/flover/CertificateCheckerScript.sml b/floatingPoint/tools/flover/CertificateCheckerScript.sml similarity index 100% rename from icing/flover/CertificateCheckerScript.sml rename to floatingPoint/tools/flover/CertificateCheckerScript.sml diff --git a/icing/flover/CertificateGeneratorScript.sml b/floatingPoint/tools/flover/CertificateGeneratorScript.sml similarity index 100% rename from icing/flover/CertificateGeneratorScript.sml rename to floatingPoint/tools/flover/CertificateGeneratorScript.sml diff --git a/icing/flover/EnvironmentsScript.sml b/floatingPoint/tools/flover/EnvironmentsScript.sml similarity index 100% rename from icing/flover/EnvironmentsScript.sml rename to floatingPoint/tools/flover/EnvironmentsScript.sml diff --git a/icing/flover/ErrorBoundsScript.sml b/floatingPoint/tools/flover/ErrorBoundsScript.sml similarity index 100% rename from icing/flover/ErrorBoundsScript.sml rename to floatingPoint/tools/flover/ErrorBoundsScript.sml diff --git a/icing/flover/ErrorIntervalInferenceScript.sml b/floatingPoint/tools/flover/ErrorIntervalInferenceScript.sml similarity index 100% rename from icing/flover/ErrorIntervalInferenceScript.sml rename to floatingPoint/tools/flover/ErrorIntervalInferenceScript.sml diff --git a/icing/flover/ErrorValidationScript.sml b/floatingPoint/tools/flover/ErrorValidationScript.sml similarity index 90% rename from icing/flover/ErrorValidationScript.sml rename to floatingPoint/tools/flover/ErrorValidationScript.sml index 78ed036a25..8351b99bc1 100644 --- a/icing/flover/ErrorValidationScript.sml +++ b/floatingPoint/tools/flover/ErrorValidationScript.sml @@ -1074,15 +1074,15 @@ Proof by (match_mp_tac REAL_LE_RMUL_IMP \\ fs[]) \\ `- (err1 * err2) <= err1 * err2` by (fs[REAL_NEG_LMUL] \\ match_mp_tac REAL_LE_RMUL_IMP - \\ REAL_ASM_ARITH_TAC) - \\ `0 <= maxAbs (e1lo, e1hi) * err2` by REAL_ASM_ARITH_TAC - \\ `0 <= maxAbs (invertInterval (e2lo, e2hi)) * err1` by REAL_ASM_ARITH_TAC + \\ OLD_REAL_ASM_ARITH_TAC) + \\ `0 <= maxAbs (e1lo, e1hi) * err2` by OLD_REAL_ASM_ARITH_TAC + \\ `0 <= maxAbs (invertInterval (e2lo, e2hi)) * err1` by OLD_REAL_ASM_ARITH_TAC \\ `maxAbs (e1lo, e1hi) * err2 <= maxAbs (e1lo, e1hi) * err2 + maxAbs (invertInterval (e2lo, e2hi)) * err1` - by (REAL_ASM_ARITH_TAC) + by (OLD_REAL_ASM_ARITH_TAC) \\ `maxAbs (e1lo, e1hi) * err2 + maxAbs (invertInterval(e2lo, e2hi)) * err1 <= maxAbs (e1lo, e1hi) * err2 + maxAbs (invertInterval (e2lo, e2hi)) * err1 + err1 * err2` - by REAL_ASM_ARITH_TAC + by OLD_REAL_ASM_ARITH_TAC (* Case distinction for divisor range positive or negative in float and real valued execution *) \\ fs [IVlo_def, IVhi_def, widenInterval_def, contained_def, noDivzero_def] @@ -1091,32 +1091,32 @@ Proof by (match_mp_tac err_prop_inversion_neg \\ qexists_tac `e2lo` \\simp[]) \\ fs [widenInterval_def, IVlo_def, IVhi_def] \\ `minAbsFun (e2lo - err2, e2hi + err2) = - (e2hi + err2)` - by (match_mp_tac minAbs_negative_iv_is_hi \\ REAL_ASM_ARITH_TAC) + by (match_mp_tac minAbs_negative_iv_is_hi \\ OLD_REAL_ASM_ARITH_TAC) \\ simp[] \\ qpat_x_assum `minAbsFun _ = _ ` kall_tac - \\ `nF1 <= err1 + nR1` by REAL_ASM_ARITH_TAC - \\ `nR1 - err1 <= nF1` by REAL_ASM_ARITH_TAC + \\ `nF1 <= err1 + nR1` by OLD_REAL_ASM_ARITH_TAC + \\ `nR1 - err1 <= nF1` by OLD_REAL_ASM_ARITH_TAC \\ `(nR2 - nF2 > 0 /\ nR2 - nF2 <= err2) \/ (nR2 - nF2 <= 0 /\ - (nR2 - nF2) <= err2)` - by REAL_ASM_ARITH_TAC + by OLD_REAL_ASM_ARITH_TAC (* Positive case for abs (nR2 - nF2) <= err2 *) - >- (`nF2 < nR2` by REAL_ASM_ARITH_TAC + >- (`nF2 < nR2` by OLD_REAL_ASM_ARITH_TAC \\ qpat_x_assum `nF2 < nR2` (fn thm => assume_tac (ONCE_REWRITE_RULE [GSYM REAL_LT_NEG] thm)) - \\ `inv (- nF2) < inv (- nR2)` by (match_mp_tac REAL_LT_INV \\ REAL_ASM_ARITH_TAC) - \\ `inv (- nF2) = - (inv nF2)` by (match_mp_tac (GSYM REAL_NEG_INV) \\ REAL_ASM_ARITH_TAC) - \\ `inv (- nR2) = - (inv nR2)` by (match_mp_tac (GSYM REAL_NEG_INV) \\ REAL_ASM_ARITH_TAC) + \\ `inv (- nF2) < inv (- nR2)` by (match_mp_tac REAL_LT_INV \\ OLD_REAL_ASM_ARITH_TAC) + \\ `inv (- nF2) = - (inv nF2)` by (match_mp_tac (GSYM REAL_NEG_INV) \\ OLD_REAL_ASM_ARITH_TAC) + \\ `inv (- nR2) = - (inv nR2)` by (match_mp_tac (GSYM REAL_NEG_INV) \\ OLD_REAL_ASM_ARITH_TAC) \\ rpt (qpat_x_assum `inv (- _) = - (inv _)` (fn thm => rule_assum_tac (fn hyp => REWRITE_RULE [thm] hyp))) - \\ `inv nR2 < inv nF2` by REAL_ASM_ARITH_TAC + \\ `inv nR2 < inv nF2` by OLD_REAL_ASM_ARITH_TAC \\ qpat_x_assum `- _ < - _` kall_tac - \\ `inv nR2 - inv nF2 < 0` by REAL_ASM_ARITH_TAC + \\ `inv nR2 - inv nF2 < 0` by OLD_REAL_ASM_ARITH_TAC \\ `- (nR2⁻¹ − nF2⁻¹) ≤ err2 * ((e2hi + err2) * (e2hi + err2))⁻¹` - by REAL_ASM_ARITH_TAC + by OLD_REAL_ASM_ARITH_TAC \\ `inv nF2 <= inv nR2 + err2 * inv ((e2hi + err2) * (e2hi + err2))` - by REAL_ASM_ARITH_TAC + by OLD_REAL_ASM_ARITH_TAC \\ `inv nR2 - err2 * inv ((e2hi + err2) * (e2hi + err2)) <= inv nF2` - by REAL_ASM_ARITH_TAC + by OLD_REAL_ASM_ARITH_TAC (* Next do a case distinction for the absolute value *) - \\ `! (x:real). ((abs x = x) /\ 0 <= x) \/ ((abs x = - x) /\ x < 0)` by REAL_ASM_ARITH_TAC + \\ `! (x:real). ((abs x = x) /\ 0 <= x) \/ ((abs x = - x) /\ x < 0)` by OLD_REAL_ASM_ARITH_TAC \\ qpat_x_assum `!x. A /\ B \/ C` (fn thm => qspec_then `(nR1:real / nR2:real) - (nF1:real / nF2:real)` @@ -1131,7 +1131,7 @@ Proof \\ conj_tac >- (fs[REAL_LE_LADD] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L - \\ conj_tac \\ REAL_ASM_ARITH_TAC) + \\ conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (qabbrev_tac `err_inv = (err2 * ((e2hi + err2) * (e2hi + err2))⁻¹)` \\ qspecl_then [`inv nR2 - err_inv`, `0`] DISJ_CASES_TAC REAL_LTE_TOTAL >- (match_mp_tac REAL_LE_TRANS @@ -1140,30 +1140,30 @@ Proof >- (fs [REAL_LE_ADD] \\ once_rewrite_tac [REAL_MUL_COMM] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L - \\ conj_tac \\ TRY REAL_ASM_ARITH_TAC + \\ conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [REAL_LE_NEG]) >- (`nR1 * inv nR2 + - (nR1 + err1) * (inv nR2 - err_inv) = nR1 * err_inv + - (inv nR2) * err1 + err1 * err_inv` - by REAL_ASM_ARITH_TAC + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2hi + err2) * (e2hi + err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ qunabbrev_tac `err_inv` \\ match_mp_tac REAL_LE_ADD2 - \\ conj_tac \\ TRY REAL_ASM_ARITH_TAC + \\ conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_ADD2 - \\ conj_tac \\ TRY REAL_ASM_ARITH_TAC + \\ conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_RMUL_IMP - \\ conj_tac \\ REAL_ASM_ARITH_TAC)) + \\ conj_tac \\ OLD_REAL_ASM_ARITH_TAC)) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `nR1 * inv nR2 + - (nR1 + - err1) * (inv nR2 - err_inv)` \\ conj_tac >- (fs [REAL_LE_ADD] \\ match_mp_tac REAL_LE_RMUL_IMP - \\ conj_tac \\ REAL_ASM_ARITH_TAC) + \\ conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (`nR1 * inv nR2 + - (nR1 + - err1) * (inv nR2 - err_inv) = nR1 * err_inv + inv nR2 * err1 - err1 * err_inv` - by REAL_ASM_ARITH_TAC + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2hi + err2) * (e2hi + err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM @@ -1172,19 +1172,19 @@ Proof \\ match_mp_tac REAL_LE_ADD2 \\ conj_tac >- (match_mp_tac REAL_LE_ADD2 - \\ conj_tac \\ TRY REAL_ASM_ARITH_TAC + \\ conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_RMUL_IMP - \\ conj_tac \\ REAL_ASM_ARITH_TAC) + \\ conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (simp [REAL_NEG_LMUL] \\ match_mp_tac REAL_LE_RMUL_IMP - \\ conj_tac \\ REAL_ASM_ARITH_TAC))))) + \\ conj_tac \\ OLD_REAL_ASM_ARITH_TAC))))) (* 0 <= - nF1 *) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `nR1 * inv nR2 + - nF1 * (inv nR2 + err2 * inv ((e2hi + err2) * (e2hi + err2)))` \\ conj_tac >- (fs[REAL_LE_LADD] \\ match_mp_tac REAL_LE_LMUL_IMP - \\ conj_tac \\ REAL_ASM_ARITH_TAC) + \\ conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (qabbrev_tac `err_inv = (err2 * ((e2hi + err2) * (e2hi + err2))⁻¹)` \\ qspecl_then [`inv nR2 + err_inv`, `0`] DISJ_CASES_TAC REAL_LTE_TOTAL >- (match_mp_tac REAL_LE_TRANS @@ -1193,11 +1193,11 @@ Proof >- (fs [REAL_LE_ADD] \\ once_rewrite_tac [REAL_MUL_COMM] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L\\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [REAL_LE_NEG]) >- (`nR1 * inv nR2 + - (nR1 + err1) * (inv nR2 + err_inv) = - nR1 * err_inv + - (inv nR2) * err1 - err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2hi + err2) * (e2hi + err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ @@ -1206,31 +1206,31 @@ Proof match_mp_tac REAL_LE_ADD2 \\ conj_tac >- (match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (simp [REAL_NEG_LMUL] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `nR1 * inv nR2 + - (nR1 + - err1) * (inv nR2 + err_inv)` \\ conj_tac >- (fs [REAL_LE_ADD] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (`nR1 * inv nR2 + - (nR1 + - err1) * (inv nR2 + err_inv) = - nR1 * err_inv + inv nR2 * err1 + err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2hi + err2) * (e2hi + err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ qunabbrev_tac `err_inv` \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))))) (* Case 2: Absolute value negative *) >- (fs[real_sub, real_div, REAL_NEG_LMUL, REAL_NEG_ADD] \\ qspecl_then [`nF1`, `0`] DISJ_CASES_TAC REAL_LTE_TOTAL @@ -1240,7 +1240,7 @@ Proof conj_tac >- (fs[REAL_LE_LADD] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (qabbrev_tac `err_inv = (err2 * ((e2hi + err2) * (e2hi + err2))⁻¹)` \\ qspecl_then [`inv nR2 - err_inv`, `0`] DISJ_CASES_TAC REAL_LTE_TOTAL >- (match_mp_tac REAL_LE_TRANS \\ @@ -1249,31 +1249,31 @@ Proof >- (fs [REAL_LE_ADD] \\ once_rewrite_tac [REAL_MUL_COMM] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L\\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [REAL_LE_NEG]) >- (`- nR1 * inv nR2 + (nR1 - err1) * (inv nR2 - err_inv) = - nR1 * err_inv + - (inv nR2) * err1 + err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((-e2hi + -err2) * (-e2hi + -err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ qunabbrev_tac `err_inv` \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [GSYM REAL_NEG_ADD, REAL_NEG_MUL2] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC)) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC)) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `- nR1 * inv nR2 + (nR1 + err1) * (inv nR2 - err_inv)` \\ conj_tac >- (fs [REAL_LE_ADD] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (`- nR1 * inv nR2 + (nR1 + err1) * (inv nR2 - err_inv) = - nR1 * err_inv + inv nR2 * err1 - err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((-e2hi + -err2) * (-e2hi + -err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ @@ -1282,20 +1282,20 @@ Proof match_mp_tac REAL_LE_ADD2 \\ conj_tac >- (match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [GSYM REAL_NEG_ADD, REAL_NEG_MUL2] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (fs [GSYM REAL_NEG_ADD, REAL_NEG_MUL2, REAL_NEG_LMUL] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))))) (* 0 <= - nF1 *) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `- nR1 * inv nR2 + nF1 * (inv nR2 + err2 * inv ((e2hi + err2) * (e2hi + err2)))` \\ conj_tac >- (fs[REAL_LE_LADD] \\ match_mp_tac REAL_LE_LMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (qabbrev_tac `err_inv = (err2 * ((e2hi + err2) * (e2hi + err2))⁻¹)` \\ qspecl_then [`inv nR2 + err_inv`, `0`] DISJ_CASES_TAC REAL_LTE_TOTAL >- (match_mp_tac REAL_LE_TRANS \\ @@ -1304,11 +1304,11 @@ Proof >- (fs [REAL_LE_ADD] \\ once_rewrite_tac [REAL_MUL_COMM] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L\\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [REAL_LE_NEG]) >- (`- nR1 * inv nR2 + (nR1 - err1) * (inv nR2 + err_inv) = nR1 * err_inv + - (inv nR2) * err1 - err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((-e2hi + -err2) * (-e2hi + -err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ @@ -1317,51 +1317,51 @@ Proof match_mp_tac REAL_LE_ADD2 \\ conj_tac >- (match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [GSYM REAL_NEG_ADD, REAL_NEG_MUL2, REAL_NEG_LMUL] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (fs [GSYM REAL_NEG_ADD, REAL_NEG_MUL2, REAL_NEG_LMUL, REAL_NEG_LMUL] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `- nR1 * inv nR2 + (nR1 + err1) * (inv nR2 + err_inv)` \\ conj_tac >- (fs [REAL_LE_ADD] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (`- nR1 * inv nR2 + (nR1 + err1) * (inv nR2 + err_inv) = nR1 * err_inv + inv nR2 * err1 + err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((-e2hi + -err2) * (-e2hi + -err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ qunabbrev_tac `err_inv` \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [GSYM REAL_NEG_ADD, REAL_NEG_MUL2, REAL_NEG_LMUL] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC)))))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC)))))) (* Negative case for abs (nR2 - nF2) <= err2 *) >- (fs [GSYM REAL_NEG_ADD, REAL_NEG_MUL2, REAL_NEG_LMUL] \\ - `nR2 <= nF2` by REAL_ASM_ARITH_TAC \\ + `nR2 <= nF2` by OLD_REAL_ASM_ARITH_TAC \\ qpat_x_assum `nR2 <= nF2` (fn thm => assume_tac (ONCE_REWRITE_RULE [GSYM REAL_LE_NEG] thm)) \\ - `inv (- nR2) <= inv (- nF2)` by (match_mp_tac REAL_INV_LE_ANTIMONO_IMPR \\ REAL_ASM_ARITH_TAC) \\ - `inv (- nR2) = - (inv nR2)` by (match_mp_tac (GSYM REAL_NEG_INV) \\ REAL_ASM_ARITH_TAC) \\ - `inv (- nF2) = - (inv nF2)` by (match_mp_tac (GSYM REAL_NEG_INV) \\ REAL_ASM_ARITH_TAC) \\ + `inv (- nR2) <= inv (- nF2)` by (match_mp_tac REAL_INV_LE_ANTIMONO_IMPR \\ OLD_REAL_ASM_ARITH_TAC) \\ + `inv (- nR2) = - (inv nR2)` by (match_mp_tac (GSYM REAL_NEG_INV) \\ OLD_REAL_ASM_ARITH_TAC) \\ + `inv (- nF2) = - (inv nF2)` by (match_mp_tac (GSYM REAL_NEG_INV) \\ OLD_REAL_ASM_ARITH_TAC) \\ rpt ( qpat_x_assum `inv (- _) = - (inv _)` (fn thm => rule_assum_tac (fn hyp => REWRITE_RULE [thm] hyp))) \\ - `inv nF2 <= inv nR2` by REAL_ASM_ARITH_TAC \\ + `inv nF2 <= inv nR2` by OLD_REAL_ASM_ARITH_TAC \\ qpat_x_assum `- _ <= - _` kall_tac \\ - `0 <= inv nR2 - inv nF2` by REAL_ASM_ARITH_TAC \\ - `(nR2⁻¹ − nF2⁻¹) ≤ err2 * ((e2hi + err2) * (e2hi + err2))⁻¹` by REAL_ASM_ARITH_TAC \\ - `inv nF2 <= inv nR2 + err2 * inv ((e2hi + err2) * (e2hi + err2))` by REAL_ASM_ARITH_TAC \\ - `inv nR2 - err2 * inv ((e2hi + err2) * (e2hi + err2)) <= inv nF2` by REAL_ASM_ARITH_TAC \\ + `0 <= inv nR2 - inv nF2` by OLD_REAL_ASM_ARITH_TAC \\ + `(nR2⁻¹ − nF2⁻¹) ≤ err2 * ((e2hi + err2) * (e2hi + err2))⁻¹` by OLD_REAL_ASM_ARITH_TAC \\ + `inv nF2 <= inv nR2 + err2 * inv ((e2hi + err2) * (e2hi + err2))` by OLD_REAL_ASM_ARITH_TAC \\ + `inv nR2 - err2 * inv ((e2hi + err2) * (e2hi + err2)) <= inv nF2` by OLD_REAL_ASM_ARITH_TAC \\ (* Next do a case distinction for the absolute value *) - `! (x:real). ((abs x = x) /\ 0 <= x) \/ ((abs x = - x) /\ x < 0)` by REAL_ASM_ARITH_TAC \\ + `! (x:real). ((abs x = x) /\ 0 <= x) \/ ((abs x = - x) /\ x < 0)` by OLD_REAL_ASM_ARITH_TAC \\ qpat_x_assum `!x. A /\ B \/ C` (fn thm => qspec_then `(nR1:real / nR2:real) - (nF1:real / nF2:real)` DISJ_CASES_TAC thm) \\ fs[real_sub, real_div, REAL_NEG_LMUL, REAL_NEG_ADD, realTheory.abs] @@ -1373,7 +1373,7 @@ Proof conj_tac >- (fs[REAL_LE_LADD] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (qabbrev_tac `err_inv = (err2 * ((e2hi + err2) * (e2hi + err2))⁻¹)` \\ qspecl_then [`inv nR2 - err_inv`, `0`] DISJ_CASES_TAC REAL_LTE_TOTAL >- (match_mp_tac REAL_LE_TRANS \\ @@ -1382,30 +1382,30 @@ Proof >- (fs [REAL_LE_ADD] \\ once_rewrite_tac [REAL_MUL_COMM] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L\\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [REAL_LE_NEG]) >- (`nR1 * inv nR2 + - (nR1 + err1) * (inv nR2 - err_inv) = nR1 * err_inv + - (inv nR2) * err1 + err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2hi + err2) * (e2hi + err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ qunabbrev_tac `err_inv` \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC)) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC)) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `nR1 * inv nR2 + - (nR1 + - err1) * (inv nR2 - err_inv)` \\ conj_tac >- (fs [REAL_LE_ADD] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (`nR1 * inv nR2 + - (nR1 + - err1) * (inv nR2 - err_inv) = nR1 * err_inv + inv nR2 * err1 - err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2hi + err2) * (e2hi + err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ @@ -1414,19 +1414,19 @@ Proof match_mp_tac REAL_LE_ADD2 \\ conj_tac >- (match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (simp [REAL_NEG_LMUL] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))))) (* 0 <= - nF1 *) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `nR1 * inv nR2 + - nF1 * (inv nR2 + err2 * inv ((e2hi + err2) * (e2hi + err2)))` \\ conj_tac >- (fs[REAL_LE_LADD] \\ match_mp_tac REAL_LE_LMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (qabbrev_tac `err_inv = (err2 * ((e2hi + err2) * (e2hi + err2))⁻¹)` \\ qspecl_then [`inv nR2 + err_inv`, `0`] DISJ_CASES_TAC REAL_LTE_TOTAL >- (match_mp_tac REAL_LE_TRANS \\ @@ -1435,11 +1435,11 @@ Proof >- (fs [REAL_LE_ADD] \\ once_rewrite_tac [REAL_MUL_COMM] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L\\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [REAL_LE_NEG]) >- (`nR1 * inv nR2 + - (nR1 + err1) * (inv nR2 + err_inv) = - nR1 * err_inv + - (inv nR2) * err1 - err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2hi + err2) * (e2hi + err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ @@ -1448,31 +1448,31 @@ Proof match_mp_tac REAL_LE_ADD2 \\ conj_tac >- (match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (simp [REAL_NEG_LMUL] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `nR1 * inv nR2 + - (nR1 + - err1) * (inv nR2 + err_inv)` \\ conj_tac >- (fs [REAL_LE_ADD] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (`nR1 * inv nR2 + - (nR1 + - err1) * (inv nR2 + err_inv) = - nR1 * err_inv + inv nR2 * err1 + err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2hi + err2) * (e2hi + err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ qunabbrev_tac `err_inv` \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))))) (* Case 2: Absolute value negative *) >- (qspecl_then [`nF1`, `0`] DISJ_CASES_TAC REAL_LTE_TOTAL (* nF1 < 0 *) @@ -1481,7 +1481,7 @@ Proof conj_tac >- (fs[REAL_LE_LADD] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (qabbrev_tac `err_inv = (err2 * ((e2hi + err2) * (e2hi + err2))⁻¹)` \\ qspecl_then [`inv nR2 - err_inv`, `0`] DISJ_CASES_TAC REAL_LTE_TOTAL >- (match_mp_tac REAL_LE_TRANS \\ @@ -1490,30 +1490,30 @@ Proof >- (fs [REAL_LE_ADD] \\ once_rewrite_tac [REAL_MUL_COMM] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L\\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [REAL_LE_NEG]) >- (`- nR1 * inv nR2 + (nR1 - err1) * (inv nR2 - err_inv) = - nR1 * err_inv + - (inv nR2) * err1 + err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2hi + err2) * (e2hi + err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ qunabbrev_tac `err_inv` \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC)) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC)) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `- nR1 * inv nR2 + (nR1 + err1) * (inv nR2 - err_inv)` \\ conj_tac >- (fs [REAL_LE_ADD] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (`- nR1 * inv nR2 + (nR1 + err1) * (inv nR2 - err_inv) = - nR1 * err_inv + inv nR2 * err1 - err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2hi + err2) * (e2hi + err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ @@ -1522,19 +1522,19 @@ Proof match_mp_tac REAL_LE_ADD2 \\ conj_tac >- (match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (fs [GSYM REAL_NEG_ADD, REAL_NEG_MUL2, REAL_NEG_LMUL] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))))) (* 0 <= - nF1 *) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `- nR1 * inv nR2 + nF1 * (inv nR2 + err2 * inv ((e2hi + err2) * (e2hi + err2)))` \\ conj_tac >- (fs[REAL_LE_LADD] \\ match_mp_tac REAL_LE_LMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (qabbrev_tac `err_inv = (err2 * ((e2hi + err2) * (e2hi + err2))⁻¹)` \\ qspecl_then [`inv nR2 + err_inv`, `0`] DISJ_CASES_TAC REAL_LTE_TOTAL >- (match_mp_tac REAL_LE_TRANS \\ @@ -1543,11 +1543,11 @@ Proof >- (fs [REAL_LE_ADD] \\ once_rewrite_tac [REAL_MUL_COMM] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L\\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [REAL_LE_NEG]) >- (`- nR1 * inv nR2 + (nR1 - err1) * (inv nR2 + err_inv) = nR1 * err_inv + - (inv nR2) * err1 - err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2hi + err2) * (e2hi + err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ @@ -1556,42 +1556,42 @@ Proof match_mp_tac REAL_LE_ADD2 \\ conj_tac >- (match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (fs [REAL_NEG_LMUL] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `- nR1 * inv nR2 + (nR1 + err1) * (inv nR2 + err_inv)` \\ conj_tac >- (fs [REAL_LE_ADD] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (`- nR1 * inv nR2 + (nR1 + err1) * (inv nR2 + err_inv) = nR1 * err_inv + inv nR2 * err1 + err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2hi + err2) * (e2hi + err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ qunabbrev_tac `err_inv` \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))))))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))))))) >- (CCONTR_TAC \\ rule_assum_tac (fn thm => REWRITE_RULE[IVlo_def, IVhi_def, widenInterval_def] thm) \\ - `e2lo <= e2hi` by REAL_ASM_ARITH_TAC \\ - `e2lo <= e2hi + err2` by REAL_ASM_ARITH_TAC \\ - `e2lo <= e2hi + err2` by REAL_ASM_ARITH_TAC \\ - REAL_ASM_ARITH_TAC) + `e2lo <= e2hi` by OLD_REAL_ASM_ARITH_TAC \\ + `e2lo <= e2hi + err2` by OLD_REAL_ASM_ARITH_TAC \\ + `e2lo <= e2hi + err2` by OLD_REAL_ASM_ARITH_TAC \\ + OLD_REAL_ASM_ARITH_TAC) >- (CCONTR_TAC \\ rule_assum_tac (fn thm => REWRITE_RULE[IVlo_def, IVhi_def, widenInterval_def] thm) \\ - `e2lo <= e2hi` by REAL_ASM_ARITH_TAC \\ - `e2lo - err2 <= e2hi` by REAL_ASM_ARITH_TAC \\ - REAL_ASM_ARITH_TAC) + `e2lo <= e2hi` by OLD_REAL_ASM_ARITH_TAC \\ + `e2lo - err2 <= e2hi` by OLD_REAL_ASM_ARITH_TAC \\ + OLD_REAL_ASM_ARITH_TAC) (* The range of the divisor lies in the range from 0 to infinity *) >- (rule_assum_tac (fn thm => @@ -1602,22 +1602,22 @@ Proof fs[contained_def, IVlo_def, IVhi_def]) \\ fs [widenInterval_def, IVlo_def, IVhi_def, invertInterval_def] \\ `minAbsFun (e2lo - err2, e2hi + err2) = (e2lo - err2)` - by (match_mp_tac minAbs_positive_iv_is_lo \\ REAL_ASM_ARITH_TAC) \\ + by (match_mp_tac minAbs_positive_iv_is_lo \\ OLD_REAL_ASM_ARITH_TAC) \\ simp[] \\ qpat_x_assum `minAbsFun _ = _ ` kall_tac \\ - `nF1 <= err1 + nR1` by REAL_ASM_ARITH_TAC \\ - `nR1 - err1 <= nF1` by REAL_ASM_ARITH_TAC \\ + `nF1 <= err1 + nR1` by OLD_REAL_ASM_ARITH_TAC \\ + `nR1 - err1 <= nF1` by OLD_REAL_ASM_ARITH_TAC \\ `(nR2 - nF2 > 0 /\ nR2 - nF2 <= err2) \/ (nR2 - nF2 <= 0 /\ - (nR2 - nF2) <= err2)` - by REAL_ASM_ARITH_TAC + by OLD_REAL_ASM_ARITH_TAC (* Positive case for abs (nR2 - nF2) <= err2 *) - >- (`nF2 < nR2` by REAL_ASM_ARITH_TAC \\ - `inv nR2 < inv nF2` by (match_mp_tac REAL_LT_INV \\ TRY REAL_ASM_ARITH_TAC) \\ - `inv nR2 - inv nF2 < 0` by REAL_ASM_ARITH_TAC \\ - `nR2⁻¹ − nF2⁻¹ ≤ err2 * ((e2lo - err2) * (e2lo - err2))⁻¹` by REAL_ASM_ARITH_TAC \\ - `inv nF2 <= inv nR2 + err2 * inv ((e2lo - err2) * (e2lo - err2))` by REAL_ASM_ARITH_TAC \\ - `inv nR2 - err2 * inv ((e2lo - err2) * (e2lo - err2)) <= inv nF2` by REAL_ASM_ARITH_TAC \\ + >- (`nF2 < nR2` by OLD_REAL_ASM_ARITH_TAC \\ + `inv nR2 < inv nF2` by (match_mp_tac REAL_LT_INV \\ TRY OLD_REAL_ASM_ARITH_TAC) \\ + `inv nR2 - inv nF2 < 0` by OLD_REAL_ASM_ARITH_TAC \\ + `nR2⁻¹ − nF2⁻¹ ≤ err2 * ((e2lo - err2) * (e2lo - err2))⁻¹` by OLD_REAL_ASM_ARITH_TAC \\ + `inv nF2 <= inv nR2 + err2 * inv ((e2lo - err2) * (e2lo - err2))` by OLD_REAL_ASM_ARITH_TAC \\ + `inv nR2 - err2 * inv ((e2lo - err2) * (e2lo - err2)) <= inv nF2` by OLD_REAL_ASM_ARITH_TAC \\ (* Next do a case distinction for the absolute value *) - `! (x:real). ((abs x = x) /\ 0 <= x) \/ ((abs x = - x) /\ x < 0)` by REAL_ASM_ARITH_TAC \\ + `! (x:real). ((abs x = x) /\ 0 <= x) \/ ((abs x = - x) /\ x < 0)` by OLD_REAL_ASM_ARITH_TAC \\ qpat_x_assum `!x. A /\ B \/ C` (fn thm => qspec_then `(nR1:real / nR2:real) - (nF1:real / nF2:real)` DISJ_CASES_TAC thm) \\ fs[realTheory.abs] @@ -1630,7 +1630,7 @@ Proof conj_tac >- (fs[REAL_LE_LADD] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (qabbrev_tac `err_inv = (err2 * ((e2lo - err2) * (e2lo - err2))⁻¹)` \\ qspecl_then [`inv nR2 - err_inv`, `0`] DISJ_CASES_TAC REAL_LTE_TOTAL >- (match_mp_tac REAL_LE_TRANS \\ @@ -1639,31 +1639,31 @@ Proof >- (fs [REAL_LE_ADD] \\ once_rewrite_tac [REAL_MUL_COMM] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L\\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [REAL_LE_NEG]) >- (`nR1 * inv nR2 + - (nR1 + err1) * (inv nR2 - err_inv) = nR1 * err_inv + - (inv nR2) * err1 + err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2lo + - err2) * (e2lo + - err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ qunabbrev_tac `err_inv` \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ simp[GSYM real_sub] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC)) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC)) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `nR1 * inv nR2 + - (nR1 + - err1) * (inv nR2 - err_inv)` \\ conj_tac >- (fs [REAL_LE_ADD] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (`nR1 * inv nR2 + - (nR1 + - err1) * (inv nR2 - err_inv) = nR1 * err_inv + inv nR2 * err1 - err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2lo + -err2) * (e2lo + -err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ @@ -1672,19 +1672,19 @@ Proof match_mp_tac REAL_LE_ADD2 \\ conj_tac >- (match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (simp [REAL_NEG_LMUL] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))))) (* 0 <= - nF1 *) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `nR1 * inv nR2 + - nF1 * (inv nR2 + err2 * inv ((e2lo - err2) * (e2lo - err2)))` \\ conj_tac >- (fs[REAL_LE_LADD] \\ match_mp_tac REAL_LE_LMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (qabbrev_tac `err_inv = (err2 * ((e2lo - err2) * (e2lo - err2))⁻¹)` \\ qspecl_then [`inv nR2 + err_inv`, `0`] DISJ_CASES_TAC REAL_LTE_TOTAL >- (match_mp_tac REAL_LE_TRANS \\ @@ -1693,11 +1693,11 @@ Proof >- (fs [REAL_LE_ADD] \\ once_rewrite_tac [REAL_MUL_COMM] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L\\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [REAL_LE_NEG]) >- (`nR1 * inv nR2 + - (nR1 + err1) * (inv nR2 + err_inv) = - nR1 * err_inv + - (inv nR2) * err1 - err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2lo + -err2) * (e2lo + -err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ @@ -1706,32 +1706,32 @@ Proof match_mp_tac REAL_LE_ADD2 \\ conj_tac >- (match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (simp [REAL_NEG_LMUL] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `nR1 * inv nR2 + - (nR1 + - err1) * (inv nR2 + err_inv)` \\ conj_tac >- (fs [REAL_LE_ADD] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (`nR1 * inv nR2 + - (nR1 + - err1) * (inv nR2 + err_inv) = - nR1 * err_inv + inv nR2 * err1 + err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2lo + -err2) * (e2lo + -err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ qunabbrev_tac `err_inv` \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ simp [GSYM real_sub] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))))) (* Case 2: Absolute value negative *) >- (fs[real_sub, real_div, REAL_NEG_LMUL, REAL_NEG_ADD] \\ qspecl_then [`nF1`, `0`] DISJ_CASES_TAC REAL_LTE_TOTAL @@ -1741,7 +1741,7 @@ Proof conj_tac >- (fs[REAL_LE_LADD] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (qabbrev_tac `err_inv = (err2 * ((e2lo - err2) * (e2lo - err2))⁻¹)` \\ qspecl_then [`inv nR2 - err_inv`, `0`] DISJ_CASES_TAC REAL_LTE_TOTAL >- (match_mp_tac REAL_LE_TRANS \\ @@ -1750,31 +1750,31 @@ Proof >- (fs [REAL_LE_ADD] \\ once_rewrite_tac [REAL_MUL_COMM] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L\\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [REAL_LE_NEG]) >- (`- nR1 * inv nR2 + (nR1 - err1) * (inv nR2 - err_inv) = - nR1 * err_inv + - (inv nR2) * err1 + err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2lo + -err2) * (e2lo + -err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ qunabbrev_tac `err_inv` \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ simp [GSYM real_sub] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC)) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC)) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `- nR1 * inv nR2 + (nR1 + err1) * (inv nR2 - err_inv)` \\ conj_tac >- (fs [REAL_LE_ADD] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (`- nR1 * inv nR2 + (nR1 + err1) * (inv nR2 - err_inv) = - nR1 * err_inv + inv nR2 * err1 - err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2lo + -err2) * (e2lo + -err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ @@ -1783,20 +1783,20 @@ Proof match_mp_tac REAL_LE_ADD2 \\ conj_tac >- (match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [GSYM REAL_NEG_ADD, REAL_NEG_MUL2] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (fs [GSYM REAL_NEG_ADD, REAL_NEG_MUL2, REAL_NEG_LMUL] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))))) (* 0 <= - nF1 *) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `- nR1 * inv nR2 + nF1 * (inv nR2 + err2 * inv ((e2lo - err2) * (e2lo - err2)))` \\ conj_tac >- (fs[REAL_LE_LADD] \\ match_mp_tac REAL_LE_LMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (qabbrev_tac `err_inv = (err2 * ((e2lo - err2) * (e2lo - err2))⁻¹)` \\ qspecl_then [`inv nR2 + err_inv`, `0`] DISJ_CASES_TAC REAL_LTE_TOTAL >- (match_mp_tac REAL_LE_TRANS \\ @@ -1805,11 +1805,11 @@ Proof >- (fs [REAL_LE_ADD] \\ once_rewrite_tac [REAL_MUL_COMM] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L\\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [REAL_LE_NEG]) >- (`- nR1 * inv nR2 + (nR1 - err1) * (inv nR2 + err_inv) = nR1 * err_inv + - (inv nR2) * err1 - err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2lo + -err2) * (e2lo + -err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ @@ -1818,42 +1818,42 @@ Proof match_mp_tac REAL_LE_ADD2 \\ conj_tac >- (match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (fs [REAL_NEG_LMUL] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `- nR1 * inv nR2 + (nR1 + err1) * (inv nR2 + err_inv)` \\ conj_tac >- (fs [REAL_LE_ADD] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (`- nR1 * inv nR2 + (nR1 + err1) * (inv nR2 + err_inv) = nR1 * err_inv + inv nR2 * err1 + err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2lo + -err2) * (e2lo + -err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ qunabbrev_tac `err_inv` \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ simp [GSYM real_sub] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC)))))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC)))))) (* Negative case for abs (nR2 - nF2) <= err2 *) >- (fs [GSYM REAL_NEG_ADD, REAL_NEG_MUL2, REAL_NEG_LMUL] \\ - `nR2 <= nF2` by REAL_ASM_ARITH_TAC \\ - `inv nF2 <= inv nR2` by (match_mp_tac REAL_INV_LE_ANTIMONO_IMPR \\ REAL_ASM_ARITH_TAC) \\ - `0 <= inv nR2 - inv nF2` by REAL_ASM_ARITH_TAC \\ - `(nR2⁻¹ − nF2⁻¹) ≤ err2 * ((e2lo - err2) * (e2lo - err2))⁻¹` by REAL_ASM_ARITH_TAC \\ - `inv nF2 <= inv nR2 + err2 * inv ((e2lo - err2) * (e2lo - err2))` by REAL_ASM_ARITH_TAC \\ - `inv nR2 - err2 * inv ((e2lo - err2) * (e2lo - err2)) <= inv nF2` by REAL_ASM_ARITH_TAC \\ + `nR2 <= nF2` by OLD_REAL_ASM_ARITH_TAC \\ + `inv nF2 <= inv nR2` by (match_mp_tac REAL_INV_LE_ANTIMONO_IMPR \\ OLD_REAL_ASM_ARITH_TAC) \\ + `0 <= inv nR2 - inv nF2` by OLD_REAL_ASM_ARITH_TAC \\ + `(nR2⁻¹ − nF2⁻¹) ≤ err2 * ((e2lo - err2) * (e2lo - err2))⁻¹` by OLD_REAL_ASM_ARITH_TAC \\ + `inv nF2 <= inv nR2 + err2 * inv ((e2lo - err2) * (e2lo - err2))` by OLD_REAL_ASM_ARITH_TAC \\ + `inv nR2 - err2 * inv ((e2lo - err2) * (e2lo - err2)) <= inv nF2` by OLD_REAL_ASM_ARITH_TAC \\ (* Next do a case distinction for the absolute value *) - `! (x:real). ((abs x = x) /\ 0 <= x) \/ ((abs x = - x) /\ x < 0)` by REAL_ASM_ARITH_TAC \\ + `! (x:real). ((abs x = x) /\ 0 <= x) \/ ((abs x = - x) /\ x < 0)` by OLD_REAL_ASM_ARITH_TAC \\ qpat_x_assum `!x. A /\ B \/ C` (fn thm => qspec_then `(nR1:real / nR2:real) - (nF1:real / nF2:real)` DISJ_CASES_TAC thm) \\ fs[real_sub, real_div, REAL_NEG_LMUL, REAL_NEG_ADD, realTheory.abs] @@ -1865,7 +1865,7 @@ Proof conj_tac >- (fs[REAL_LE_LADD] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (qabbrev_tac `err_inv = (err2 * ((e2lo - err2) * (e2lo - err2))⁻¹)` \\ qspecl_then [`inv nR2 - err_inv`, `0`] DISJ_CASES_TAC REAL_LTE_TOTAL >- (match_mp_tac REAL_LE_TRANS \\ @@ -1874,31 +1874,31 @@ Proof >- (fs [REAL_LE_ADD] \\ once_rewrite_tac [REAL_MUL_COMM] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L\\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [REAL_LE_NEG]) >- (`nR1 * inv nR2 + - (nR1 + err1) * (inv nR2 - err_inv) = nR1 * err_inv + - (inv nR2) * err1 + err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2lo + -err2) * (e2lo + -err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ qunabbrev_tac `err_inv` \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ simp [GSYM real_sub] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC)) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC)) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `nR1 * inv nR2 + - (nR1 + - err1) * (inv nR2 - err_inv)` \\ conj_tac >- (fs [REAL_LE_ADD] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (`nR1 * inv nR2 + - (nR1 + - err1) * (inv nR2 - err_inv) = nR1 * err_inv + inv nR2 * err1 - err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2lo + -err2) * (e2lo + -err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ @@ -1907,19 +1907,19 @@ Proof match_mp_tac REAL_LE_ADD2 \\ conj_tac >- (match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (simp [REAL_NEG_LMUL] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))))) (* 0 <= - nF1 *) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `nR1 * inv nR2 + - nF1 * (inv nR2 + err2 * inv ((e2lo - err2) * (e2lo - err2)))` \\ conj_tac >- (fs[REAL_LE_LADD] \\ match_mp_tac REAL_LE_LMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (qabbrev_tac `err_inv = (err2 * ((e2lo - err2) * (e2lo - err2))⁻¹)` \\ qspecl_then [`inv nR2 + err_inv`, `0`] DISJ_CASES_TAC REAL_LTE_TOTAL >- (match_mp_tac REAL_LE_TRANS \\ @@ -1928,11 +1928,11 @@ Proof >- (fs [REAL_LE_ADD] \\ once_rewrite_tac [REAL_MUL_COMM] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L\\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [REAL_LE_NEG]) >- (`nR1 * inv nR2 + - (nR1 + err1) * (inv nR2 + err_inv) = - nR1 * err_inv + - (inv nR2) * err1 - err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2lo + -err2) * (e2lo + -err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ @@ -1941,32 +1941,32 @@ Proof match_mp_tac REAL_LE_ADD2 \\ conj_tac >- (match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (simp [REAL_NEG_LMUL] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `nR1 * inv nR2 + - (nR1 + - err1) * (inv nR2 + err_inv)` \\ conj_tac >- (fs [REAL_LE_ADD] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (`nR1 * inv nR2 + - (nR1 + - err1) * (inv nR2 + err_inv) = - nR1 * err_inv + inv nR2 * err1 + err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2lo + -err2) * (e2lo + -err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ qunabbrev_tac `err_inv` \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ simp [GSYM real_sub] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))))) (* Case 2: Absolute value negative *) >- (qspecl_then [`nF1`, `0`] DISJ_CASES_TAC REAL_LTE_TOTAL (* nF1 < 0 *) @@ -1975,7 +1975,7 @@ Proof conj_tac >- (fs[REAL_LE_LADD] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (qabbrev_tac `err_inv = (err2 * ((e2lo - err2) * (e2lo - err2))⁻¹)` \\ qspecl_then [`inv nR2 - err_inv`, `0`] DISJ_CASES_TAC REAL_LTE_TOTAL >- (match_mp_tac REAL_LE_TRANS \\ @@ -1984,31 +1984,31 @@ Proof >- (fs [REAL_LE_ADD] \\ once_rewrite_tac [REAL_MUL_COMM] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L\\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [REAL_LE_NEG]) >- (`- nR1 * inv nR2 + (nR1 - err1) * (inv nR2 - err_inv) = - nR1 * err_inv + - (inv nR2) * err1 + err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2lo + -err2) * (e2lo + -err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ qunabbrev_tac `err_inv` \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ simp [GSYM real_sub] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC)) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC)) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `- nR1 * inv nR2 + (nR1 + err1) * (inv nR2 - err_inv)` \\ conj_tac >- (fs [REAL_LE_ADD] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (`- nR1 * inv nR2 + (nR1 + err1) * (inv nR2 - err_inv) = - nR1 * err_inv + inv nR2 * err1 - err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2lo + -err2) * (e2lo + -err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ @@ -2017,19 +2017,19 @@ Proof match_mp_tac REAL_LE_ADD2 \\ conj_tac >- (match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (fs [GSYM REAL_NEG_ADD, REAL_NEG_MUL2, REAL_NEG_LMUL] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))))) (* 0 <= - nF1 *) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `- nR1 * inv nR2 + nF1 * (inv nR2 + err2 * inv ((e2lo - err2) * (e2lo - err2)))` \\ conj_tac >- (fs[REAL_LE_LADD] \\ match_mp_tac REAL_LE_LMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (qabbrev_tac `err_inv = (err2 * ((e2lo - err2) * (e2lo - err2))⁻¹)` \\ qspecl_then [`inv nR2 + err_inv`, `0`] DISJ_CASES_TAC REAL_LTE_TOTAL >- (match_mp_tac REAL_LE_TRANS \\ @@ -2038,11 +2038,11 @@ Proof >- (fs [REAL_LE_ADD] \\ once_rewrite_tac [REAL_MUL_COMM] \\ match_mp_tac REAL_MUL_LE_COMPAT_NEG_L\\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ fs [REAL_LE_NEG]) >- (`- nR1 * inv nR2 + (nR1 - err1) * (inv nR2 + err_inv) = nR1 * err_inv + - (inv nR2) * err1 - err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2lo + -err2) * (e2lo + -err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ @@ -2051,32 +2051,32 @@ Proof match_mp_tac REAL_LE_ADD2 \\ conj_tac >- (match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (fs [REAL_NEG_LMUL] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))) >- (match_mp_tac REAL_LE_TRANS \\ qexists_tac `- nR1 * inv nR2 + (nR1 + err1) * (inv nR2 + err_inv)` \\ conj_tac >- (fs [REAL_LE_ADD] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC) >- (`- nR1 * inv nR2 + (nR1 + err1) * (inv nR2 + err_inv) = nR1 * err_inv + inv nR2 * err1 + err1 * err_inv` - by REAL_ASM_ARITH_TAC \\ + by OLD_REAL_ASM_ARITH_TAC \\ simp[REAL_NEG_MUL2] \\ qspecl_then [`inv ((e2lo + -err2) * (e2lo + -err2))`,`err2`] (fn thm => once_rewrite_tac [thm]) REAL_MUL_COMM \\ qunabbrev_tac `err_inv` \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ match_mp_tac REAL_LE_ADD2 \\ - conj_tac \\ TRY REAL_ASM_ARITH_TAC \\ + conj_tac \\ TRY OLD_REAL_ASM_ARITH_TAC \\ simp [GSYM real_sub] \\ match_mp_tac REAL_LE_RMUL_IMP \\ - conj_tac \\ REAL_ASM_ARITH_TAC))))))) + conj_tac \\ OLD_REAL_ASM_ARITH_TAC))))))) QED Theorem validErrorboundCorrectDiv: diff --git a/icing/flover/FPRangeValidatorScript.sml b/floatingPoint/tools/flover/FPRangeValidatorScript.sml similarity index 100% rename from icing/flover/FPRangeValidatorScript.sml rename to floatingPoint/tools/flover/FPRangeValidatorScript.sml diff --git a/icing/flover/FloverTactics.sml b/floatingPoint/tools/flover/FloverTactics.sml similarity index 100% rename from icing/flover/FloverTactics.sml rename to floatingPoint/tools/flover/FloverTactics.sml diff --git a/icing/flover/Holmakefile b/floatingPoint/tools/flover/Holmakefile similarity index 100% rename from icing/flover/Holmakefile rename to floatingPoint/tools/flover/Holmakefile diff --git a/icing/flover/IEEE_connectionScript.sml b/floatingPoint/tools/flover/IEEE_connectionScript.sml similarity index 100% rename from icing/flover/IEEE_connectionScript.sml rename to floatingPoint/tools/flover/IEEE_connectionScript.sml diff --git a/floatingPoint/tools/flover/IEEE_reverseScript.sml b/floatingPoint/tools/flover/IEEE_reverseScript.sml new file mode 100644 index 0000000000..168a7d4252 --- /dev/null +++ b/floatingPoint/tools/flover/IEEE_reverseScript.sml @@ -0,0 +1,1381 @@ +(** + Connect FloVer's idealized machine semantics to 64-bit + IEEE-754 floating-point semantics +**) +open machine_ieeeTheory binary_ieeeTheory lift_ieeeTheory realTheory RealArith + realLib; +open MachineTypeTheory ExpressionsTheory RealSimpsTheory FloverTactics + CertificateCheckerTheory FPRangeValidatorTheory IntervalValidationTheory + ExpressionAbbrevsTheory + ExpressionSemanticsTheory FloverMapTheory RealRangeArithTheory + TypeValidatorTheory ErrorValidationTheory IntervalArithTheory AbbrevsTheory + CommandsTheory ssaPrgsTheory EnvironmentsTheory FloverMapTheory IEEE_connectionTheory; +open preambleFloVer; + +val _ = new_theory "IEEE_reverse"; + +Overload abs[local] = “realax$abs” + +Definition toFlExp_def: + toFlExp ((Var v):real expr) = Var v ∧ + toFlExp (Const m c) = Const m (real_to_fp64 dmode c) ∧ + toFlExp (Unop u e1) = Unop u (toFlExp e1) ∧ + toFlExp (Binop b e1 e2) = Binop b (toFlExp e1) (toFlExp e2) ∧ + toFlExp (Fma e1 e2 e3) = Fma (toFlExp e1) (toFlExp e2) (toFlExp e3) ∧ + toFlExp (Downcast m e1) = Downcast m (toFlExp e1) +End + +Definition toFlCmd_def: + toFlCmd (Let m x e g) = Let m x (toFlExp e) (toFlCmd g) ∧ + toFlCmd (Ret e) = Ret (toFlExp e) +End + +Definition toFlEnv_def: + toFlEnv (E:num -> real option) :num -> word64 option = + λ x. case E x of + | NONE => NONE + | SOME v => SOME (real_to_fp64 dmode v) +End + +Theorem float_to_real_round_robin: + !(f:('a,'b) float). + float_is_finite f ⇒ + float_to_real ((real_to_float dmode (float_to_real f)):('a,'b) float) = + (float_to_real f) +Proof + rpt strip_tac + \\ fs[dmode_def, real_to_float_def, float_round_def] + \\ reverse $ Cases_on ‘float_is_zero f’ + >- gs[round_finite_normal_float_id] + \\ ‘∃ s e m. f = <|Sign := s; Exponent := e; Significand := m |>’ + by (Cases_on ‘f’ \\ gs[float_component_equality]) + \\ ‘float_to_real f = 0’ + by (rveq \\ gs[float_tests, float_to_real_def]) + \\ simp[] + (* Just for simplicity, could also prove that condition is true... *) + \\ TOP_CASE_TAC \\ gs[] +QED + +Theorem eval_expr_gives_IEEE_reverse: + !(e:real expr) E1 E2 Gamma vR A fVars dVars. + validTypes e Gamma /\ + approxEnv E1 (toRExpMap Gamma) A fVars dVars (toREnv E2) /\ + validRanges e A E1 (toRTMap (toRExpMap Gamma)) /\ + validErrorbound e Gamma A dVars /\ + FPRangeValidator e A Gamma dVars /\ + eval_expr (toREnv E2) (toRExpMap Gamma) e vR M64 /\ + domain (usedVars e) DIFF domain dVars ⊆ domain fVars ∧ + is64BitEval e /\ + is64BitEnv Gamma /\ + noDowncast e /\ + (∀v. + v ∈ domain dVars ⇒ + ∃vF m. + ((toREnv E2) v = SOME vF ∧ FloverMapTree_find (Var v) Gamma = SOME m ∧ + validFloatValue vF m)) ==> + ?v. + eval_expr_float (toFlExp e) E2 = SOME v /\ + eval_expr (toREnv E2) (toRExpMap Gamma) e (fp64_to_real v) M64 +Proof + Induct_on `e` \\ rw[toFlExp_def] + \\ inversion `eval_expr _ _ _ _ _` eval_expr_cases + \\ once_rewrite_tac [eval_expr_float_def] + \\ fs[noDowncast_def] + >- gs [toREnv_def, eval_expr_cases, fp64_to_real_def, + real_to_fp64_def, fp64_to_float_float_to_fp64, + CaseEq"option"] + >- ( + simp[eval_expr_cases, fp64_to_real_def, real_to_fp64_def, + fp64_to_float_float_to_fp64, real_to_float_def, dmode_def, + float_round_def, float_is_zero_to_real] + \\ gs[perturb_def] + \\ ‘eval_expr (toREnv E2) (toRExpMap Gamma) (Const M64 v) v M64’ + by (gs[eval_expr_cases] + \\ qexists_tac ‘0’ \\ gs[perturb_def, mTypeToR_pos]) + \\ ‘validFloatValue v M64’ + by (drule FPRangeValidator_sound + \\ disch_then $ qspecl_then [‘Const M64 v’, ‘v’, ‘M64’] mp_tac + \\ gs[eval_expr_cases] \\ impl_tac \\ gs[] + \\ qexists_tac ‘0’ \\ gs[perturb_def, mTypeToR_pos]) + \\ first_x_assum $ assume_tac o SIMP_RULE std_ss [validFloatValue_def] + \\ gs[] + >- ( + ‘normalizes (:52 # 11) v’ by gs[normalValue_implies_normalization] + \\ imp_res_tac relative_error + \\ qexists_tac ‘e’ \\ simp[float_is_zero_to_real] + \\ ‘~ (v = 0 ∨ 1 + e = 0)’ + by (CCONTR_TAC \\ gs[] \\ rveq + >- (gs[normalizes_def] + \\ ‘0 < inv (2 pow 1022)’ by gs[] + \\ ‘0 < 0’ suffices_by gs[] + \\ irule REAL_LTE_TRANS \\ first_assum $ irule_at Any + \\ gs[]) + \\ ‘e = -1’ by (pop_assum $ mp_tac \\ REAL_ARITH_TAC) + \\ ‘1 /2 pow 53 < 1’ by ( + irule REAL_LTE_TRANS \\ qexists_tac ‘1/1’ + \\ reverse conj_tac >- gs[] + \\ rewrite_tac [real_div] + \\ irule REAL_LT_LMUL_IMP \\ reverse conj_tac >- gs[] + \\ irule REAL_LT_INV \\ gs[] + \\ irule REAL_LT_TRANS \\ qexists_tac ‘&53’ + \\ gs[POW_2_LT]) + \\ ‘1 < 1:real’ suffices_by gs[] + \\ irule REAL_LET_TRANS \\ first_x_assum $ irule_at Any + \\ gs[]) + \\ gs[perturb_def] + \\ imp_res_tac normal_not_denormal \\ gs[] + \\ fs[REAL_INV_1OVER, mTypeToR_def, isCompat_def]) + >- ( + gs[perturb_def, mTypeToR_def, float_is_zero_to_real] + \\ qspec_then ‘v’ mp_tac (Q.INST_TYPE [‘:'t’|->‘:52’,‘:'w’|->‘:11’] absolute_error_denormal) + \\ impl_tac + >- (‘abs v < 2 / 2 pow (INT_MAX (:11) - 1)’ by ( + fs[denormalTranslatedValue_implies_finiteness, + float_is_finite, denormal_def, minValue_pos_def] + \\ rewrite_tac [INT_MAX_def, INT_MIN_def, dimindex_11, EVAL “2 ** (11 - 1) - 1 - 1”] + \\ irule REAL_LT_TRANS + \\ first_assum $ irule_at Any + \\ fs[minExponentPos_def]) + \\ rpt conj_tac + >~ [‘1 < INT_MAX (:11)’] >- gs[] + >- ( + irule REAL_LTE_TRANS + \\ first_assum $ irule_at Any + \\ simp[threshold_def] + \\ rewrite_tac[REAL_INV_1OVER] + \\ EVAL_TAC) + \\ irule REAL_LTE_TRANS \\ qexists_tac ‘2 / 2 pow (INT_MAX (:11) - 1)’ + \\ reverse conj_tac >- gs[] + \\ pop_assum $ mp_tac \\ REAL_ARITH_TAC) + \\ rpt strip_tac \\ TOP_CASE_TAC \\ gs[minExponentPos_def] + >- ( + qexists_tac ‘-v’ \\ gs[] + \\ irule REAL_LE_TRANS \\ first_x_assum $ irule_at Any + \\ gs[]) + \\ qexists_tac ‘float_to_real ((round roundTiesToEven v):(52,11) float) - v’ \\ gs[] + \\ conj_tac >- REAL_ARITH_TAC + \\ irule REAL_LE_TRANS \\ first_x_assum $ irule_at Any + \\ gs[]) + >- (gvs[denormal_def] \\ qexists_tac ‘0’ \\ gs[mTypeToR_pos]) + ) + >- ( + gs[eval_expr_float_def, eval_expr_cases] + \\ qpat_x_assum ‘validTypes _ _’ $ assume_tac o ONCE_REWRITE_RULE [validTypes_def] + \\ gs[] + \\ first_x_assum $ drule_then drule + \\ qpat_x_assum ‘validRanges _ _ _ _’ $ assume_tac o ONCE_REWRITE_RULE [validRanges_def] + \\ gs[] + \\ qpat_x_assum ‘validErrorbound _ _ _ _’ $ assume_tac o ONCE_REWRITE_RULE [validErrorbound_def] + \\ gs[] + \\ ‘FPRangeValidator e A Gamma dVars’ by ( + qpat_x_assum ‘FPRangeValidator _ _ _ _’ $ assume_tac o ONCE_REWRITE_RULE [FPRangeValidator_def] + \\ gs[]) + \\ gs[] + \\ ‘m' = M64’ by (Cases_on ‘m'’ \\ gs[isCompat_def]) + \\ gvs[] + \\ disch_then drule \\ impl_tac + >- (gs[Once usedVars_def, Once is64BitEval_def] \\ metis_tac[]) + \\ strip_tac \\ gs[eval_expr_float_def] + \\ simp[Once eval_expr_cases] + \\ first_x_assum $ irule_at Any \\ gs[isCompat_def] + \\ gs[fp64_negate_def, fp64_to_real_def, fp64_to_float_float_to_fp64, + evalUnop_def, float_to_real_negate]) + >- ( + qpat_x_assum ‘validErrorbound _ _ _ _’ $ + mp_tac o ONCE_REWRITE_RULE [validErrorbound_def] + \\ fs[option_case_eq] \\ rpt (TOP_CASE_TAC \\ fs[])) + >- ( + gs[eval_expr_float_def, eval_expr_cases] + \\ qpat_x_assum ‘validTypes _ _’ $ assume_tac o ONCE_REWRITE_RULE [validTypes_def] + \\ gs[] + \\ first_x_assum $ drule_then drule + \\ qpat_x_assum ‘validRanges _ _ _ _’ $ assume_tac o ONCE_REWRITE_RULE [validRanges_def] + \\ gs[] + \\ qpat_x_assum ‘validErrorbound _ _ _ _’ $ assume_tac o ONCE_REWRITE_RULE [validErrorbound_def] + \\ gs[] + \\ Cases_on ‘FloverMapTree_find e A’ \\ gs[] \\ PairCases_on ‘x’ \\ gs[] + \\ ‘FPRangeValidator e A Gamma dVars’ by ( + qpat_x_assum ‘FPRangeValidator _ _ _ _’ $ assume_tac o ONCE_REWRITE_RULE [FPRangeValidator_def] + \\ gs[]) + \\ gs[] + \\ ‘m1 = M64’ by (Cases_on ‘m1’ \\ gs[isCompat_def]) + \\ gvs[] \\ disch_then drule \\ impl_tac + >- (gs[Once usedVars_def, Once is64BitEval_def] \\ metis_tac[]) + \\ strip_tac \\ gs[eval_expr_float_def] + \\ first_assum $ irule_at Any \\ gs[isCompat_def] + \\ gs[fp64_to_real_def, fp64_sqrt_def, fp64_to_float_float_to_fp64, + dmode_def, evalUnop_def] + \\ ‘validFloatValue (float_to_real (fp64_to_float v)) M64’ + by (drule FPRangeValidator_sound + \\ rpt $ disch_then drule \\ impl_tac + >- gs[Once usedVars_def] + \\ gs[]) + \\ qpat_assum ‘validRanges e _ _ _’ $ mp_then Any strip_assume_tac validRanges_single + \\ rename [‘eval_expr E1 _ (toREval e) vR_e REAL’, ‘FloverMapTree_find e A = SOME (iv_e, err_e)’] + \\ ‘contained (float_to_real (fp64_to_float v)) + (widenInterval (FST iv_e, SND iv_e) err_e)’ + by ( + irule distance_gives_iv + \\ qexists_tac `vR_e` \\ gvs[contained_def] + \\ drule validErrorbound_sound + \\ disch_then drule \\ gs[eval_Real_def, eval_Fin_def] + \\ disch_then $ qspec_then ‘vR_e’ mp_tac \\ impl_tac + >- gs[Once usedVars_def] + \\ strip_tac + \\ first_x_assum irule + \\ qexists_tac `M64` \\ gs[]) + \\ ‘0 < FST (widenInterval (FST iv_e, SND iv_e) err_e)’ + by ( + qpat_x_assum ‘validErrorbound _ _ _ _’ + (fn thm => mp_tac (ONCE_REWRITE_RULE [validErrorbound_def] thm)) + \\ fs[option_case_eq] \\ rpt (TOP_CASE_TAC \\ fs[])) + \\ ‘0 < float_to_real (fp64_to_float v)’ + by (gs[contained_def, widenInterval_def] \\ irule REAL_LTE_TRANS + \\ asm_exists_tac \\ gs[]) + \\ ‘(fp64_to_float v).Sign = 0w’ + by imp_res_tac zero_lt_sign_zero + \\ ‘validFloatValue (evalUnop Sqrt (float_to_real (fp64_to_float v))) M64’ + by ( + drule FPRangeValidator_sound + \\ disch_then + (qspecl_then + [`Unop Sqrt e`, + `evalUnop Sqrt (float_to_real (fp64_to_float v))`, `M64`] + irule) + \\ gvs[] + \\ qexists_tac ‘e’ \\ fs[] + \\ rpt conj_tac + >- (simp[Once validTypes_def, isCompat_def] \\ first_x_assum MATCH_ACCEPT_TAC) + >- simp[Once validErrorbound_def] + >- (simp[Once validRanges_def] \\ asm_exists_tac \\ fs[] + \\ fs[] \\ rveq \\ fs[]) + \\ irule Unop_sqrt' + \\ qexistsl_tac [‘0’, `M64`, ‘M64’, `float_to_real (fp64_to_float v)`] + \\ fs[perturb_def, evalUnop_def, mTypeToR_pos, isCompat_def]) + \\ qpat_x_assum `validFloatValue (evalUnop _ _) M64` $ + assume_tac o SIMP_RULE std_ss [validFloatValue_def] + \\ gs[] + (* normal sqrt *) + >- ( + Q.ISPEC_THEN `(fp64_to_float v):(52,11) float` + impl_subgoal_tac + float_sqrt_relative + >- (rpt conj_tac + \\ fs[validFloatValue_def, + normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, + GSYM float_is_zero_to_real, float_is_finite, evalUnop_def, + sqrtable_def, + normalizes_def]) + \\ gvs[dmode_def] \\ qexists_tac ‘e'’ + \\ fs[perturb_def, evalUnop_def] + \\ imp_res_tac normal_not_denormal \\ simp[] + \\ simp[REAL_INV_1OVER, mTypeToR_def, isCompat_def]) + (* denormal sqrt *) + >- ( + Q.ISPEC_THEN `(fp64_to_float v):(52,11) float` + impl_subgoal_tac + float_sqrt_relative_denorm + >- ( + rpt conj_tac + >- fs[validFloatValue_def, + normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, float_is_finite, + GSYM float_is_zero_to_real, evalUnop_def] + >- fs[sqrtable_def] + >- ( + fs[normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, float_is_finite, + GSYM float_is_zero_to_real, evalUnop_def, denormal_def, minValue_pos_def] + \\ irule REAL_LT_TRANS + \\ qexists_tac ‘abs (sqrt (float_to_real (fp64_to_float v)))* &(2 ** minExponentPos M64)’ + \\ gs[] \\ EVAL_TAC) + >- ( + irule REAL_LT_TRANS \\ qexists_tac ‘maxValue M64’ + \\ fs[threshold_64_bit_lt_maxValue, denormal_def] + \\ irule REAL_LTE_TRANS \\ qexists_tac ‘minValue_pos M64’ + \\ fs[minValue_pos_def, maxValue_def, GSYM REAL_OF_NUM_POW, evalUnop_def] + \\ EVAL_TAC) + \\ fs[INT_MAX_def, INT_MIN_def, dimindex_11]) + \\ gvs[dmode_def] \\ qexists_tac ‘e'’ + \\ fs[perturb_def, evalUnop_def] + \\ simp[REAL_INV_1OVER, mTypeToR_def, minExponentPos_def]) + (* sqrt 0 *) + \\ ‘0 < sqrt (float_to_real (fp64_to_float v))’ by (irule SQRT_POS_LT \\ gs[]) + \\ gs[evalUnop_def]) + >~ [‘Binop b e1 e2’] + >- ( + imp_res_tac validRanges_single + \\ rw_thm_asm `validTypes _ _` validTypes_def + \\ rw_thm_asm `validRanges _ _ _ _` validRanges_def + \\ fs[eval_expr_float_def, optionLift_def] + \\ imp_res_tac validTypes_exec + \\ rveq + \\ `m1 = M64 /\ m2 = M64` + by (fs[is64BitEnv_def] + \\ conj_tac \\ first_x_assum irule \\ find_exists_tac \\ fs[]) + \\ rveq + \\ rw_thm_asm `is64BitEval _` is64BitEval_def \\ fs[] + \\ ntac 2 + (first_x_assum + (qspecl_then [`E1`, `E2`, `Gamma`] assume_tac)) + \\ first_x_assum (qspecl_then [`v1`, `A`, `fVars`, `dVars`] destruct) + >- ( + rpt conj_tac \\ fs[] + >- ( + qpat_x_assum ‘validErrorbound _ _ _ _’ + (fn thm => mp_tac (ONCE_REWRITE_RULE [validErrorbound_def] thm)) + \\ fs[option_case_eq] \\ rpt (TOP_CASE_TAC \\ fs[])) + >- ( + rw_thm_asm `FPRangeValidator _ _ _ _` FPRangeValidator_def + \\ fs[] \\ rveq + \\ rw_asm_star `FloverMapTree_find (Binop _ _ _) A = _` + \\ rw_asm_star `FloverMapTree_find (Binop _ _ _) Gamma = _`) + \\ rw_thm_asm `domain (usedVars _) DIFF _ SUBSET _` usedVars_def + \\ fs[domain_union, DIFF_DEF, SUBSET_DEF, Once usedVars_def] + \\ rpt strip_tac \\ first_x_assum irule \\ simp[Once usedVars_def]) + \\ first_x_assum (qspecl_then [`v2`, `A`, `fVars`, `dVars`] destruct) + >- ( + rpt conj_tac \\ fs[] + >- ( + qpat_x_assum ‘validErrorbound _ _ _ _’ + (fn thm => mp_tac (ONCE_REWRITE_RULE [validErrorbound_def] thm)) + \\ fs[option_case_eq] \\ rpt (TOP_CASE_TAC \\ fs[])) + >- ( + rw_thm_asm `FPRangeValidator _ _ _ _` FPRangeValidator_def + \\ fs[] \\ rveq + \\ rw_asm_star `FloverMapTree_find (Binop _ _ _) A = _` + \\ rw_asm_star `FloverMapTree_find (Binop _ _ _) Gamma = _`) + \\ rw_thm_asm `domain (usedVars _) DIFF _ SUBSET _` usedVars_def + \\ fs[domain_union, DIFF_DEF, SUBSET_DEF]) + \\ fs[] + \\ rename1 `eval_expr_float (toFlExp e1) _ = SOME vF1` + \\ rename1 `eval_expr_float (toFlExp e2) _ = SOME vF2` + \\ imp_res_tac validRanges_single + \\ rename1 `FloverMapTree_find e2 A = SOME (iv2, err2)` + \\ rename1 `FloverMapTree_find e1 A = SOME (iv1, err1)` + \\ rename1 `eval_expr E1 _ (toREval e2) nR2 REAL` + \\ rename1 `eval_expr E1 _ (toREval e1) nR1 REAL` + (* Obtain evaluation for E2 *) + \\ ‘!vF2 m2. eval_expr (toREnv E2) (toRExpMap Gamma) e2 vF2 m2 ==> + abs (nR2 - vF2) <= err2’ + by (qspecl_then [`e2`, `E1`, `toREnv E2`, `A`,`nR2`, + `err2`, `FST iv2`, `SND iv2`, `fVars`, + `dVars`,`Gamma`] destruct validErrorbound_sound + \\ rpt conj_tac \\ fs[] + >- (fs [DIFF_DEF, SUBSET_DEF] + \\ rpt strip_tac \\ first_x_assum irule + \\ once_rewrite_tac [usedVars_def] \\ fs[domain_union]) + \\ qpat_x_assum ‘validErrorbound _ _ _ _’ + (fn thm => mp_tac (ONCE_REWRITE_RULE [validErrorbound_def] thm)) + \\ fs[option_case_eq] \\ rpt (TOP_CASE_TAC \\ fs[])) + \\ `contained (float_to_real (fp64_to_float vF2)) + (widenInterval (FST iv2, SND iv2) err2)` + by (irule distance_gives_iv + \\ qexists_tac `nR2` \\ fs [contained_def] + \\ first_x_assum irule + \\ qexists_tac `M64` \\ gs[fp64_to_real_def]) + \\ `b = Div ==> float_to_real (fp64_to_float vF2) <> 0` + by (strip_tac \\ rveq + \\ qpat_x_assum ‘validErrorbound _ _ _ _’ + (fn thm => mp_tac (ONCE_REWRITE_RULE [validErrorbound_def] thm)) + \\ fs[widenInterval_def, contained_def, noDivzero_def] + \\ rpt strip_tac + >- (CCONTR_TAC \\ fs[] \\ rveq + \\ `0 < 0:real` + by (irule REAL_LET_TRANS + \\ qexists_tac `SND iv2 + err2` \\ fs[]) + \\ fs[]) + >- (CCONTR_TAC \\ fs[] \\ rveq + \\ `0 < 0:real` + by (irule REAL_LTE_TRANS + \\ qexists_tac `FST iv2 - err2` \\ fs[]) + \\ fs[]) + >- (CCONTR_TAC \\ fs[] \\ rveq + \\ `0 < 0:real` + by (irule REAL_LET_TRANS + \\ qexists_tac `SND iv2 + err2` \\ fs[]) + \\ fs[]) + \\ CCONTR_TAC \\ fs[] \\ rveq + \\ `0 < 0:real` + by (irule REAL_LTE_TRANS + \\ qexists_tac `FST iv2 - err2` \\ fs[]) + \\ fs[]) + \\ `validFloatValue + (evalBinop b (float_to_real (fp64_to_float vF1)) + (float_to_real (fp64_to_float vF2))) M64` + by (drule FPRangeValidator_sound + \\ disch_then + (qspecl_then + [`Binop b e1 e2`, + `evalBinop b (float_to_real (fp64_to_float vF1)) + (float_to_real (fp64_to_float vF2))`, + `M64`] irule) + \\ fs[] + \\ qexistsl_tac [`e1`, `e2`] \\ fs[] + \\ rpt conj_tac + >- (simp[Once validTypes_def] \\ first_x_assum MATCH_ACCEPT_TAC) + >- (simp[Once validRanges_def] \\ asm_exists_tac \\ fs[] + \\ fs[] \\ rveq \\ fs[]) + \\ irule Binop_dist' + \\ qexistsl_tac [‘0’, `M64`, `M64`, ‘M64’, `float_to_real (fp64_to_float vF1)`, + `float_to_real (fp64_to_float vF2)`] + \\ Cases_on `b` + \\ fs[perturb_def, evalBinop_def, mTypeToR_pos, fp64_to_real_def]) + \\ `validFloatValue (float_to_real (fp64_to_float vF1)) M64` + by (drule FPRangeValidator_sound + \\ disch_then + (qspecl_then + [`e1`, `float_to_real (fp64_to_float vF1)`, + `M64`] irule) + \\ fs[] + \\ qexistsl_tac [`e1`] \\ fs[] + \\ rpt conj_tac + >- (rw_thm_asm `domain (usedVars _) DIFF _ SUBSET _` usedVars_def + \\ fs[domain_union, DIFF_DEF, SUBSET_DEF, Once usedVars_def]) + >- (rw_thm_asm `FPRangeValidator _ _ _ _` FPRangeValidator_def + \\ fs[] \\ rveq + \\ rw_asm_star `FloverMapTree_find (Binop _ _ _) A = _` + \\ rw_asm_star `FloverMapTree_find (Binop _ _ _) Gamma = _`) + >- ( + qpat_x_assum ‘validErrorbound _ _ _ _’ + (fn thm => mp_tac (ONCE_REWRITE_RULE [validErrorbound_def] thm)) + \\ fs[option_case_eq] \\ rpt (TOP_CASE_TAC \\ fs[])) + \\ gs[fp64_to_real_def]) + \\ `validFloatValue (float_to_real (fp64_to_float vF2)) M64` + by (drule FPRangeValidator_sound + \\ disch_then + (qspecl_then + [`e2`, `float_to_real (fp64_to_float vF2)`, + `M64`] irule) + \\ fs[] + \\ qexists_tac `e2` \\ fs[] + \\ rpt conj_tac + >- (rw_thm_asm `domain (usedVars _) DIFF _ SUBSET _` usedVars_def + \\ fs[domain_union, DIFF_DEF, SUBSET_DEF]) + >- (rw_thm_asm `FPRangeValidator _ _ _ _` FPRangeValidator_def + \\ fs[] \\ rveq + \\ rw_asm_star `FloverMapTree_find (Binop _ _ _) A = _` + \\ rw_asm_star `FloverMapTree_find (Binop _ _ _) Gamma = _`) + >- ( + qpat_x_assum ‘validErrorbound _ _ _ _’ + (fn thm => mp_tac (ONCE_REWRITE_RULE [validErrorbound_def] thm)) + \\ fs[option_case_eq] \\ rpt (TOP_CASE_TAC \\ fs[])) + \\ gs[fp64_to_real_def]) + \\ qpat_x_assum `validFloatValue (evalBinop _ _ _) M64` + $ assume_tac o SIMP_RULE std_ss [validFloatValue_def] + (** Case distinction for operator **) + \\ Cases_on `b` \\ fs[GSYM noDivzero_def, optionLift_def, PULL_EXISTS] + \\ simp[Once eval_expr_cases] + (* Addition, result normal *) + >- ( + fs[fp64_add_def, fp64_to_float_float_to_fp64, evalBinop_def] + \\ Q.ISPECL_THEN [`(fp64_to_float vF1):(52,11) float`, + `(fp64_to_float vF2):(52,11) float`] + impl_subgoal_tac + float_add_relative + >- ( + rpt conj_tac + \\ fs[validFloatValue_def, + normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, + GSYM float_is_zero_to_real, float_is_finite, evalBinop_def]) + \\ fs[dmode_def] + \\ qexistsl_tac [`M64`, `M64`, `float_to_real (fp64_to_float vF1)`, + `float_to_real (fp64_to_float vF2)`, `e`] + \\ fs[perturb_def, evalBinop_def] + \\ imp_res_tac normal_not_denormal + \\ simp[REAL_INV_1OVER, mTypeToR_def, fp64_to_real_def, fp64_to_float_float_to_fp64] + \\ gs[fp64_to_real_def]) + (* addition, result denormal *) + >- ( + fs[fp64_add_def, fp64_to_float_float_to_fp64, evalBinop_def] + \\ Q.ISPECL_THEN [`(fp64_to_float vF1):(52,11) float`, + `(fp64_to_float vF2):(52,11) float`] + impl_subgoal_tac + float_add_relative_denorm + >- ( + rpt conj_tac + >- fs[validFloatValue_def, + normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, float_is_finite, + GSYM float_is_zero_to_real, evalBinop_def] + >- fs[validFloatValue_def, + normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, float_is_finite, + GSYM float_is_zero_to_real, evalBinop_def] + >- ( + fs[normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, float_is_finite, + GSYM float_is_zero_to_real, evalBinop_def, denormal_def, minValue_pos_def] + \\ irule REAL_LT_TRANS + \\ qpat_x_assum ‘abs _ * _ < 1’ $ irule_at Any + \\ fs[GSYM REAL_OF_NUM_POW, minExponentPos_def]) + >- ( + irule REAL_LT_TRANS \\ qexists_tac ‘maxValue M64’ + \\ fs[threshold_64_bit_lt_maxValue, denormal_def] + \\ irule REAL_LTE_TRANS \\ qexists_tac ‘minValue_pos M64’ + \\ fs[minValue_pos_def, maxValue_def, GSYM REAL_OF_NUM_POW] + \\ EVAL_TAC) + \\ fs[INT_MAX_def, INT_MIN_def, dimindex_11]) + \\ fs[dmode_def] + \\ qexistsl_tac [`M64`, `M64`, `float_to_real (fp64_to_float vF1)`, + `float_to_real (fp64_to_float vF2)`, `e`] + \\ fs[perturb_def, evalBinop_def] + \\ fs[mTypeToR_def, minExponentPos_def, REAL_INV_1OVER, fp64_to_real_def, + fp64_to_float_float_to_fp64]) + (* result = 0 *) + >- (IMP_RES_TAC validValue_gives_float_value + \\ fs[REAL_LNEG_UNIQ, evalBinop_def] + \\ fs[fp64_add_def, dmode_def, fp64_to_float_float_to_fp64] + \\ fs[float_add_def, float_round_with_flags_def] + \\ qexistsl_tac [`M64`, `M64`, `float_to_real (fp64_to_float vF1)`, + `float_to_real (fp64_to_float vF2)`, `0:real`] + \\ fs[perturb_def, mTypeToR_pos, evalBinop_def] + \\ `2 * abs (0:real) <= ulp (:52 #11)` + by (fs[REAL_ABS_0, ulp_def, ULP_def, REAL_OF_NUM_POW] + \\ once_rewrite_tac [real_div] + \\ irule REAL_LE_MUL \\ fs[] + \\ irule REAL_LE_INV \\ fs[]) + \\ fs[float_to_real_round_zero_is_zero, fp64_to_real_def, + fp64_to_float_float_to_fp64]) + (* Subtraction, normal value *) + >- ( + fs[fp64_sub_def, fp64_to_float_float_to_fp64, evalBinop_def] + \\ Q.ISPECL_THEN [`(fp64_to_float vF1):(52,11) float`, + `(fp64_to_float vF2):(52,11) float`] + impl_subgoal_tac + float_sub_relative + >- ( + rpt conj_tac + \\ fs[validFloatValue_def, + normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, + GSYM float_is_zero_to_real, float_is_finite, evalBinop_def]) + \\ fs[dmode_def] + \\ qexistsl_tac [`M64`, `M64`, `float_to_real (fp64_to_float vF1)`, + `float_to_real (fp64_to_float vF2)`, `e`] + \\ fs[perturb_def, evalBinop_def] + \\ imp_res_tac normal_not_denormal + \\ simp[REAL_INV_1OVER, mTypeToR_def, fp64_to_real_def, fp64_to_float_float_to_fp64] + \\ gs[fp64_to_real_def]) + (* Subtraction, denormal value *) + >- ( + fs[fp64_sub_def, fp64_to_float_float_to_fp64, evalBinop_def] + \\ Q.ISPECL_THEN [`(fp64_to_float vF1):(52,11) float`, + `(fp64_to_float vF2):(52,11) float`] + impl_subgoal_tac + float_sub_relative_denorm + >- ( + rpt conj_tac + >- fs[validFloatValue_def, + normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, float_is_finite, + GSYM float_is_zero_to_real, evalBinop_def] + >- fs[validFloatValue_def, + normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, float_is_finite, + GSYM float_is_zero_to_real, evalBinop_def] + >- ( + fs[normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, float_is_finite, + GSYM float_is_zero_to_real, evalBinop_def, denormal_def, minValue_pos_def] + \\ irule REAL_LT_TRANS + \\ qpat_x_assum ‘abs _ * _ < 1’ $ irule_at Any + \\ gs[] \\ EVAL_TAC) + >- ( + irule REAL_LT_TRANS \\ qexists_tac ‘maxValue M64’ + \\ fs[threshold_64_bit_lt_maxValue, denormal_def] + \\ irule REAL_LTE_TRANS \\ qexists_tac ‘minValue_pos M64’ + \\ fs[minValue_pos_def, maxValue_def, GSYM REAL_OF_NUM_POW] + \\ EVAL_TAC) + \\ fs[INT_MAX_def, INT_MIN_def, dimindex_11]) + \\ fs[dmode_def] + \\ qexistsl_tac [`M64`, `M64`, `float_to_real (fp64_to_float vF1)`, + `float_to_real (fp64_to_float vF2)`, `e`] + \\ fs[perturb_def, evalBinop_def, fp64_to_real_def, fp64_to_float_float_to_fp64] + \\ fs[mTypeToR_def, minExponentPos_def, REAL_INV_1OVER]) + (* subtraction, result = 0 *) + >- ( + fs[evalBinop_def] + \\ qpat_x_assum `float_to_real (fp64_to_float _) = _` MP_TAC + \\ simp[real_sub, REAL_LNEG_UNIQ, evalBinop_def] + \\ fs[fp64_sub_def, dmode_def, fp64_to_float_float_to_fp64] + \\ fs[float_sub_def] + \\ fs[perturb_def, mTypeToR_pos, evalBinop_def] + \\ fs[validValue_gives_float_value, float_round_with_flags_def] + \\ strip_tac + \\ qexistsl_tac [`M64`, `M64`, `float_to_real (fp64_to_float vF1)`, + `float_to_real (fp64_to_float vF2)`, `0:real`] + \\ fs[perturb_def, mTypeToR_pos, evalBinop_def] + \\ fs[validValue_gives_float_value, float_round_with_flags_def] + \\ `2 * abs (0:real) <= ulp (:52 #11)` + by (fs[REAL_ABS_0, ulp_def, ULP_def, REAL_OF_NUM_POW] + \\ once_rewrite_tac [real_div] + \\ irule REAL_LE_MUL \\ fs[] + \\ irule REAL_LE_INV \\ fs[]) + \\ fs[ float_to_real_round_zero_is_zero, fp64_to_real_def, fp64_to_float_float_to_fp64]) + (* Multiplication, normal result *) + >- ( + fs[fp64_mul_def, fp64_to_float_float_to_fp64, evalBinop_def] + \\ Q.ISPECL_THEN [`(fp64_to_float vF1):(52,11) float`, + `(fp64_to_float vF2):(52,11) float`] + impl_subgoal_tac + float_mul_relative + >- ( + rpt conj_tac + \\ fs[validFloatValue_def, + normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, + GSYM float_is_zero_to_real, float_is_finite, evalBinop_def]) + \\ fs[dmode_def] + \\ qexistsl_tac [`M64`, `M64`, `float_to_real (fp64_to_float vF1)`, + `float_to_real (fp64_to_float vF2)`, `e`] + \\ fs[perturb_def, evalBinop_def] + \\ imp_res_tac normal_not_denormal + \\ fs[mTypeToR_def, REAL_INV_1OVER, fp64_to_real_def, fp64_to_float_float_to_fp64]) + (* Multiplication, denormal result *) + >- ( + fs[fp64_mul_def, fp64_to_float_float_to_fp64, evalBinop_def] + \\ Q.ISPECL_THEN [`(fp64_to_float vF1):(52,11) float`, + `(fp64_to_float vF2):(52,11) float`] + impl_subgoal_tac + float_mul_relative_denorm + >- ( + rpt conj_tac + >- fs[validFloatValue_def, + normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, float_is_finite, + GSYM float_is_zero_to_real, evalBinop_def] + >- fs[validFloatValue_def, + normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, float_is_finite, + GSYM float_is_zero_to_real, evalBinop_def] + >- ( + fs[normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, float_is_finite, + GSYM float_is_zero_to_real, evalBinop_def, denormal_def, minValue_pos_def] + \\ irule REAL_LT_TRANS + \\ qpat_x_assum ‘abs _ * _ < 1’ $ irule_at Any + \\ gs[minExponentPos_def] + \\ irule REAL_LET_TRANS + \\ qexists_tac ‘1 * abs (float_to_real (fp64_to_float vF1) * float_to_real (fp64_to_float vF2)) ’ + \\ reverse conj_tac >- gs[] + \\ irule REAL_LT_RMUL_IMP \\ fs[float_is_zero_def] + \\ imp_res_tac validValue_gives_float_value \\ gvs[]) + >- ( + irule REAL_LT_TRANS \\ qexists_tac ‘maxValue M64’ + \\ fs[threshold_64_bit_lt_maxValue, denormal_def] + \\ irule REAL_LTE_TRANS \\ qexists_tac ‘minValue_pos M64’ + \\ fs[minValue_pos_def, maxValue_def, GSYM REAL_OF_NUM_POW] + \\ EVAL_TAC) + \\ fs[INT_MAX_def, INT_MIN_def, dimindex_11]) + \\ fs[dmode_def] + \\ qexistsl_tac [`M64`, `M64`, `float_to_real (fp64_to_float vF1)`, + `float_to_real (fp64_to_float vF2)`, `e`] + \\ fs[perturb_def, evalBinop_def, fp64_to_real_def, fp64_to_float_float_to_fp64] + \\ fs[mTypeToR_def, minExponentPos_def, REAL_INV_1OVER]) + (* multiplication, result = 0 *) + >- ( + fs[evalBinop_def, REAL_ENTIRE, fp64_mul_def, float_mul_def, + GSYM float_is_zero_to_real, float_is_zero_def] + THENL [ Cases_on `float_value (fp64_to_float vF1)`, + Cases_on `float_value (fp64_to_float vF2)`] + \\ fs[validValue_gives_float_value] + \\ fs[float_round_with_flags_def, dmode_def, + fp64_to_float_float_to_fp64, perturb_def] + \\ Cases_on `(fp64_to_float vF1).Sign ≠ (fp64_to_float vF2).Sign` + \\ `2 * abs (0:real) <= ulp (:52 #11)` + by (fs[REAL_ABS_0, ulp_def, ULP_def, REAL_OF_NUM_POW] + \\ once_rewrite_tac [real_div] + \\ irule REAL_LE_MUL \\ fs[] + \\ irule REAL_LE_INV \\ fs[]) + \\ fs [round_roundTiesToEven_is_plus_zero, + round_roundTiesToEven_is_minus_zero, zero_to_real, + fp64_to_real_def, fp64_to_float_float_to_fp64 + ] + \\ qexistsl_tac [`M64`, `M64`, `float_to_real (fp64_to_float vF1)`, + `float_to_real (fp64_to_float vF2)`, `0:real`] + \\ rveq + \\ fs[GSYM float_is_zero_to_real, float_is_zero_def, + mTypeToR_pos, perturb_def]) + (* Division, normal result *) + >- ( + fs[fp64_div_def, fp64_to_float_float_to_fp64, evalBinop_def] + \\ Q.ISPECL_THEN [`(fp64_to_float vF1):(52,11) float`, + `(fp64_to_float vF2):(52,11) float`] + impl_subgoal_tac + float_div_relative + >- (rpt conj_tac + \\ fs[validFloatValue_def, + normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, + GSYM float_is_zero_to_real, float_is_finite, evalBinop_def]) + \\ fs[dmode_def] + \\ qexistsl_tac [`M64`, `M64`, `float_to_real (fp64_to_float vF1)`, + `float_to_real (fp64_to_float vF2)`, `e`] + \\ fs[perturb_def, evalBinop_def, fp64_to_real_def, fp64_to_float_float_to_fp64] + \\ imp_res_tac normal_not_denormal + \\ gs[mTypeToR_def] \\ rewrite_tac[REAL_INV_1OVER] + \\ qpat_x_assum ‘_ ≤ 1’ mp_tac \\ simp[]) + (* Division, denormal result *) + >- ( + fs[fp64_div_def, fp64_to_float_float_to_fp64, evalBinop_def] + \\ Q.ISPECL_THEN [`(fp64_to_float vF1):(52,11) float`, + `(fp64_to_float vF2):(52,11) float`] + impl_subgoal_tac + float_div_relative_denorm + >- ( + rpt conj_tac + >- fs[validFloatValue_def, + normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, float_is_finite, + GSYM float_is_zero_to_real, evalBinop_def] + >- fs[validFloatValue_def, + normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, float_is_finite, + GSYM float_is_zero_to_real, evalBinop_def] + >- fs[validFloatValue_def, + normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, float_is_finite, + GSYM float_is_zero_to_real, evalBinop_def] + >- ( + fs[normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, float_is_finite, + GSYM float_is_zero_to_real, evalBinop_def, denormal_def, minValue_pos_def] + \\ irule REAL_LT_TRANS + \\ qpat_x_assum ‘_ < 1’ $ irule_at Any \\ gs[] + \\ EVAL_TAC) + >- ( + irule REAL_LT_TRANS \\ qexists_tac ‘maxValue M64’ + \\ fs[threshold_64_bit_lt_maxValue, denormal_def] + \\ irule REAL_LTE_TRANS \\ qexists_tac ‘minValue_pos M64’ + \\ fs[minValue_pos_def, maxValue_def, GSYM REAL_OF_NUM_POW] + \\ irule REAL_LE_TRANS \\ qexists_tac ‘1’ \\ conj_tac + >- (once_rewrite_tac[GSYM REAL_INV1] \\ irule REAL_INV_LE_ANTIMONO_IMPR + \\ fs[POW_2_LE1]) + \\ fs[POW_2_LE1] \\ EVAL_TAC) + \\ fs[INT_MAX_def, INT_MIN_def, dimindex_11]) + \\ fs[dmode_def] + \\ qexistsl_tac [`M64`, `M64`, `float_to_real (fp64_to_float vF1)`, + `float_to_real (fp64_to_float vF2)`, `e`] + \\ fs[perturb_def, evalBinop_def, fp64_to_real_def, fp64_to_float_float_to_fp64] + \\ gs[mTypeToR_def, minExponentPos_def] \\ rewrite_tac[REAL_INV_1OVER] + \\ qpat_x_assum ‘_ ≤ 1’ mp_tac \\ simp[]) + (* division, result = 0 *) + >- ( + fs[fp64_div_def, dmode_def, fp64_to_float_float_to_fp64, + float_div_def, evalBinop_def] + \\ `float_to_real (fp64_to_float vF1) = 0` + by (imp_res_tac div_eq0_general) + \\ rw_thm_asm `float_to_real (fp64_to_float vF1) = 0` (GSYM float_is_zero_to_real) + \\ fs[float_is_zero_def] + \\ Cases_on `float_value (fp64_to_float vF1)` + \\ fs[validValue_gives_float_value] + \\ simp [float_round_with_flags_def] + \\ Cases_on `(fp64_to_float vF1).Sign ≠ (fp64_to_float vF2).Sign` + \\ `2 * abs (0:real) <= ulp (:52 #11)` + by (fs[REAL_ABS_0, ulp_def, ULP_def, REAL_OF_NUM_POW] + \\ once_rewrite_tac [real_div] + \\ irule REAL_LE_MUL \\ fs[] + \\ irule REAL_LE_INV \\ fs[]) + \\ fs [round_roundTiesToEven_is_plus_zero, + round_roundTiesToEven_is_minus_zero, zero_to_real] + \\ rveq + \\ `float_to_real (fp64_to_float vF1) = 0:real` + by (fs[GSYM float_is_zero_to_real, float_is_zero_def]) + \\ qexistsl_tac [`M64`, `M64`, `float_to_real (fp64_to_float vF1)`, + `float_to_real (fp64_to_float vF2)`, `0:real`] + \\ fs[perturb_def, mTypeToR_pos, float_to_real_round_zero_is_zero] + \\ gs[fp64_to_real_def, fp64_to_float_float_to_fp64])) + >~ [‘Fma e1 e2 e3’] + >- ( + imp_res_tac validRanges_single + \\ rw_thm_asm `validTypes _ _` validTypes_def + \\ rw_thm_asm `validRanges _ _ _ _` validRanges_def + \\ fs[eval_expr_float_def, optionLift_def] + \\ IMP_RES_TAC validTypes_exec + \\ rveq \\ first_x_assum kall_tac + \\ `m1 = M64 /\ m2 = M64 /\ m3 = M64` + by (fs[is64BitEnv_def] + \\ rpt conj_tac \\ first_x_assum irule \\ find_exists_tac \\ fs[]) + \\ rveq + \\ rw_thm_asm `is64BitEval _` is64BitEval_def \\ fs[] + \\ ntac 3 + (first_x_assum + (qspecl_then [`E1`, `E2`, `Gamma`] assume_tac)) + \\ first_x_assum (qspecl_then [`v1`, `A`, `fVars`, `dVars`] destruct) + >- ( + rpt conj_tac \\ fs[] + >- ( + qpat_x_assum ‘validErrorbound _ _ _ _’ + (fn thm => assume_tac (ONCE_REWRITE_RULE [validErrorbound_def] thm)) + \\ fs[option_case_eq] + \\ pop_assum mp_tac \\ rpt (TOP_CASE_TAC \\ fs[])) + >- (rw_thm_asm `FPRangeValidator _ _ _ _` FPRangeValidator_def + \\ fs[] \\ rveq + \\ rw_asm_star `FloverMapTree_find (Fma _ _ _) A = _` + \\ rw_asm_star `FloverMapTree_find (Fma _ _ _) Gamma = _`) + \\ rw_thm_asm `domain (usedVars _) DIFF _ SUBSET _` usedVars_def + \\ fs[domain_union, DIFF_DEF, SUBSET_DEF, Once usedVars_def] + \\ rpt strip_tac \\ first_x_assum irule \\ simp[Once usedVars_def]) + \\ first_x_assum (qspecl_then [`v2`, `A`, `fVars`, `dVars`] destruct) + >- ( + rpt conj_tac \\ fs[] + >- ( + qpat_x_assum ‘validErrorbound _ _ _ _’ + (fn thm => assume_tac (ONCE_REWRITE_RULE [validErrorbound_def] thm)) + \\ fs[option_case_eq] + \\ pop_assum mp_tac \\ rpt (TOP_CASE_TAC \\ fs[])) + >- (rw_thm_asm `FPRangeValidator _ _ _ _` FPRangeValidator_def + \\ fs[] \\ rveq + \\ rw_asm_star `FloverMapTree_find (Fma _ _ _) A = _` + \\ rw_asm_star `FloverMapTree_find (Fma _ _ _) Gamma = _`) + \\ rw_thm_asm `domain (usedVars _) DIFF _ SUBSET _` usedVars_def + \\ fs[domain_union, DIFF_DEF, SUBSET_DEF]) + \\ first_x_assum (qspecl_then [`v3`, `A`, `fVars`, `dVars`] destruct) + >- ( + rpt conj_tac \\ fs[] + >- ( + qpat_x_assum ‘validErrorbound _ _ _ _’ + (fn thm => assume_tac (ONCE_REWRITE_RULE [validErrorbound_def] thm)) + \\ fs[option_case_eq] + \\ pop_assum mp_tac \\ rpt (TOP_CASE_TAC \\ fs[])) + >- (rw_thm_asm `FPRangeValidator _ _ _ _` FPRangeValidator_def + \\ fs[] \\ rveq + \\ rw_asm_star `FloverMapTree_find (Fma _ _ _) A = _` + \\ rw_asm_star `FloverMapTree_find (Fma _ _ _) Gamma = _`) + \\ rw_thm_asm `domain (usedVars _) DIFF _ SUBSET _` usedVars_def + \\ fs[domain_union, DIFF_DEF, SUBSET_DEF]) + \\ rename1 ‘eval_expr_float (toFlExp e1) E2 = SOME vF1’ + \\ rename1 ‘eval_expr_float (toFlExp e2) E2 = SOME vF2’ + \\ rename1 ‘eval_expr_float (toFlExp e3) E2 = SOME vF3’ + \\ `validFloatValue + (evalFma (float_to_real (fp64_to_float vF1)) + (float_to_real (fp64_to_float vF2)) + (float_to_real (fp64_to_float vF3))) M64` + by (drule FPRangeValidator_sound + \\ disch_then + (qspecl_then + [`Fma e1 e2 e3`, + `evalFma (float_to_real (fp64_to_float vF1)) + (float_to_real (fp64_to_float vF2)) + (float_to_real (fp64_to_float vF3))`, + `M64`] irule) + \\ fs[] + \\ qexistsl_tac [`e1`, `e2`, ‘e3’] \\ fs[] + \\ rpt conj_tac + >- (simp[Once validTypes_def] \\ first_x_assum MATCH_ACCEPT_TAC) + >- (simp[Once validRanges_def] \\ find_exists_tac \\ fs[] + \\ fs[] \\ rveq \\ fs[]) + \\ simp[Once eval_expr_cases] + \\ qexistsl_tac [`M64`, `M64`, ‘M64’, `float_to_real (fp64_to_float vF1)`, + `float_to_real (fp64_to_float vF2)`, + `float_to_real (fp64_to_float vF3)`, `0:real`] + \\ fs[perturb_def, evalFma_def, mTypeToR_pos, fp64_to_real_def]) + \\ `validFloatValue (float_to_real (fp64_to_float vF1)) M64` + by (drule FPRangeValidator_sound + \\ disch_then + (qspecl_then + [`e1`, `float_to_real (fp64_to_float vF1)`, + `M64`] irule) + \\ fs[] + \\ qexistsl_tac [`e1`] \\ fs[] + \\ rpt conj_tac + >- (rw_thm_asm `domain (usedVars _) DIFF _ SUBSET _` usedVars_def + \\ fs[domain_union, DIFF_DEF, SUBSET_DEF, Once usedVars_def]) + >- (rw_thm_asm `FPRangeValidator _ _ _ _` FPRangeValidator_def + \\ fs[] \\ rveq + \\ rw_asm_star `FloverMapTree_find (Fma _ _ _) A = _` + \\ rw_asm_star `FloverMapTree_find (Fma _ _ _) Gamma = _`) + >- ( + qpat_x_assum ‘validErrorbound _ _ _ _’ + (fn thm => assume_tac (ONCE_REWRITE_RULE [validErrorbound_def] thm)) + \\ fs[option_case_eq] + \\ pop_assum mp_tac \\ rpt (TOP_CASE_TAC \\ fs[])) + \\ fs[fp64_to_real_def]) + \\ `validFloatValue (float_to_real (fp64_to_float vF2)) M64` + by (drule FPRangeValidator_sound + \\ disch_then + (qspecl_then + [`e2`, `float_to_real (fp64_to_float vF2)`, + `M64`] irule) + \\ fs[] + \\ qexists_tac `e2` \\ fs[] + \\ rpt conj_tac + >- (rw_thm_asm `domain (usedVars _) DIFF _ SUBSET _` usedVars_def + \\ fs[domain_union, DIFF_DEF, SUBSET_DEF]) + >- (rw_thm_asm `FPRangeValidator _ _ _ _` FPRangeValidator_def + \\ fs[] \\ rveq + \\ rw_asm_star `FloverMapTree_find (Fma _ _ _) A = _` + \\ rw_asm_star `FloverMapTree_find (Fma _ _ _) Gamma = _`) + >- ( + qpat_x_assum ‘validErrorbound _ _ _ _’ + (fn thm => assume_tac (ONCE_REWRITE_RULE [validErrorbound_def] thm)) + \\ fs[option_case_eq] + \\ pop_assum mp_tac \\ rpt (TOP_CASE_TAC \\ fs[])) + \\ gs[fp64_to_real_def]) + \\ `validFloatValue (float_to_real (fp64_to_float vF3)) M64` + by (drule FPRangeValidator_sound + \\ disch_then + (qspecl_then + [`e3`, `float_to_real (fp64_to_float vF3)`, + `M64`] irule) + \\ fs[] + \\ qexists_tac `e3` \\ fs[] + \\ rpt conj_tac + >- (rw_thm_asm `domain (usedVars _) DIFF _ SUBSET _` usedVars_def + \\ fs[domain_union, DIFF_DEF, SUBSET_DEF]) + >- (rw_thm_asm `FPRangeValidator _ _ _ _` FPRangeValidator_def + \\ fs[] \\ rveq + \\ rw_asm_star `FloverMapTree_find (Fma _ _ _) A = _` + \\ rw_asm_star `FloverMapTree_find (Fma _ _ _) Gamma = _`) + >- ( + qpat_x_assum ‘validErrorbound _ _ _ _’ + (fn thm => assume_tac (ONCE_REWRITE_RULE [validErrorbound_def] thm)) + \\ fs[option_case_eq] + \\ pop_assum mp_tac \\ rpt (TOP_CASE_TAC \\ fs[])) + \\ gs[fp64_to_real_def]) + \\ qpat_x_assum ‘validFloatValue (evalFma _ _ _) _’ + (assume_tac o SIMP_RULE std_ss [validFloatValue_def]) + \\ fs[optionLift_def] + \\ simp[Once eval_expr_cases, PULL_EXISTS] + \\ rewrite_tac [CONJ_ASSOC] + \\ ntac 3 (once_rewrite_tac [CONJ_COMM] \\ asm_exists_tac \\ fs[]) + \\ fs[evalFma_def, evalBinop_def, fp64_mul_add_def, fp64_to_real_def, + fp64_to_float_float_to_fp64] + >- ( + Q.ISPECL_THEN [`(fp64_to_float vF1):(52,11) float`, + `(fp64_to_float vF2):(52,11) float`, + `(fp64_to_float vF3):(52,11) float`] + impl_subgoal_tac + float_mul_add_relative + >- ( + rpt conj_tac + \\ fs[validFloatValue_def, + normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, + GSYM float_is_zero_to_real, float_is_finite, evalFma_def, evalBinop_def]) + \\ fs[dmode_def] + \\ fs[perturb_def] + \\ qexistsl_tac [`e`] + \\ pop_assum (rewrite_tac o single) + \\ fs[perturb_def, evalBinop_def] + \\ imp_res_tac normal_not_denormal + \\ fs[mTypeToR_def, REAL_INV_1OVER]) + (* result denormal *) + >- ( + fs[fp64_mul_add_def, fp64_to_float_float_to_fp64, evalFma_def] + \\ Q.ISPECL_THEN [`(fp64_to_float vF1):(52,11) float`, + `(fp64_to_float vF2):(52,11) float`, + `(fp64_to_float vF3):(52,11) float`] + impl_subgoal_tac + float_mul_add_relative_denorm + >- ( + rpt conj_tac + >- fs[validFloatValue_def, + normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, float_is_finite, + GSYM float_is_zero_to_real, evalBinop_def] + >- fs[validFloatValue_def, + normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, float_is_finite, + GSYM float_is_zero_to_real, evalBinop_def] + >- fs[validFloatValue_def, + normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, float_is_finite, + GSYM float_is_zero_to_real, evalBinop_def] + >- ( + fs[normalTranslatedValue_implies_finiteness, + denormalTranslatedValue_implies_finiteness, + normalValue_implies_normalization, float_is_finite, + GSYM float_is_zero_to_real, evalBinop_def, denormal_def, minValue_pos_def] + \\ irule REAL_LT_TRANS + \\ qpat_x_assum ‘_ < 1’ $ irule_at Any \\ gs[] + \\ EVAL_TAC) + >- ( + irule REAL_LT_TRANS \\ qexists_tac ‘maxValue M64’ + \\ fs[threshold_64_bit_lt_maxValue, denormal_def] + \\ irule REAL_LTE_TRANS \\ qexists_tac ‘minValue_pos M64’ + \\ fs[minValue_pos_def, maxValue_def, GSYM REAL_OF_NUM_POW] + \\ EVAL_TAC) + \\ fs[INT_MAX_def, INT_MIN_def, dimindex_11]) + \\ fs[dmode_def] \\ qexists_tac ‘e’ + \\ fs[perturb_def, evalFma_def] + \\ fs[mTypeToR_def, minExponentPos_def, REAL_INV_1OVER]) + (* result = 0 *) + >- ( + imp_res_tac validValue_gives_float_value + \\ fs[REAL_LNEG_UNIQ, evalFma_def, evalBinop_def] + \\ fs[fp64_add_def, dmode_def, fp64_mul_def, fp64_to_float_float_to_fp64] + \\ fs[float_mul_add_def, float_round_with_flags_def] + \\ qexists_tac `0:real` + \\ fs[perturb_def, mTypeToR_pos, evalBinop_def] + \\ fs[float_is_nan_def, float_is_infinite_def] + \\ `2 * abs (0:real) <= ulp (:52 #11)` + by (fs[REAL_ABS_0, ulp_def, ULP_def, REAL_OF_NUM_POW] + \\ once_rewrite_tac [real_div] + \\ irule REAL_LE_MUL \\ fs[] + \\ irule REAL_LE_INV \\ fs[]) + \\ fs[float_to_real_round_zero_is_zero])) +QED + +(** The below does not work because of double-rounding **) +(* +Theorem bstep_gives_IEEE: + !(f:real cmd) E1 E2 Gamma vR vF A fVars dVars outVars. + approxEnv E1 (toRExpMap Gamma) A fVars dVars E2 /\ + ssa f (union fVars dVars) outVars /\ + validTypesCmd f Gamma /\ + validRangesCmd f A E1 (toRTMap (toRExpMap Gamma)) /\ + validErrorboundCmd f Gamma A dVars /\ + FPRangeValidatorCmd f A Gamma dVars /\ + bstep (toREvalCmd f) E1 (toRTMap (toRExpMap Gamma)) vR REAL /\ + bstep f E2 (toRExpMap Gamma) vF M64 /\ + domain (freeVars f) DIFF domain dVars ⊆ domain fVars ∧ + is64BitBstep f /\ + is64BitEnv Gamma /\ + noDowncastFun f /\ + (∀ x v. E2 x = SOME v ⇒ float_to_real ((real_to_float dmode v):(52,11) float) = v) ∧ + (∀v. + v ∈ domain dVars ⇒ + ∃vF m. + (E2 v = SOME vF ∧ FloverMapTree_find (Var v) Gamma = SOME m ∧ + validFloatValue vF m)) ==> + ?v. + bstep_float (toFlCmd f) (toFlEnv E2) = SOME v /\ + bstep f E2 (toRExpMap Gamma) + (fp64_to_real v) M64 +Proof + reverse $ Induct_on `f` + \\ simp [toFlCmd_def, Once toREvalCmd_def, is64BitBstep_def, + noDowncastFun_def] + \\ rpt strip_tac + \\ rpt (inversion `bstep (Let _ _ _ _) _ _ _ _` bstep_cases) + \\ inversion `ssa _ _ _` ssa_cases + \\ once_rewrite_tac [bstep_float_def] + \\ fs[noDowncast_def] + \\ qpat_x_assum ‘validErrorboundCmd _ _ _ _’ + (fn thm => mp_tac (ONCE_REWRITE_RULE[validErrorboundCmd_def] thm)) + \\ fs[option_case_eq] + >- ( + strip_tac \\ fs[bstep_cases, bstep_float_def] + \\ irule eval_expr_gives_IEEE_reverse + \\ rpt conj_tac + \\ fs[Once validTypesCmd_def] + >- first_x_assum $ irule_at Any + \\ gs[getRetExp_def, freeVars_def] + \\ rpt $ first_x_assum $ irule_at Any + \\ conj_tac + \\ fs[freeVars_def, Once FPRangeValidatorCmd_def, validRangesCmd_def]) + \\ rpt (TOP_CASE_TAC \\ fs[]) + \\ rpt strip_tac \\ gvs[] + \\ `?v_e. eval_expr_float (toFlExp e) (toFlEnv E2) = SOME v_e /\ + eval_expr E2 (toRExpMap Gamma) e (fp64_to_real v_e) M64` + by (irule eval_expr_gives_IEEE_reverse \\ rpt conj_tac \\ fs[] + >- fs[Once validTypesCmd_def] + >- first_x_assum $ irule_at Any + \\ qexistsl_tac [`A`, `E1`, `dVars`, `fVars`] + \\ rpt conj_tac \\ fs[] + >- (fs[Once freeVars_def, domain_union, DIFF_DEF, SUBSET_DEF] + \\ rpt strip_tac + \\ `x IN domain fVars \/ x IN domain dVars` + by (first_x_assum irule \\ fs[])) + >- (fs [Once FPRangeValidatorCmd_def]) + \\ fs[Once validRangesCmd_def]) + \\ fs[Once validRangesCmd_def] + \\ imp_res_tac validRanges_single + \\ imp_res_tac validRangesCmd_single + \\ fs[Once validTypesCmd_def] + (* prove validity of errorbound for floating-point value *) + \\ qspecl_then + [`e`, `E1`, `E2`, `A`, `v'`, `r`, + `FST iv`, `SND iv`, `fVars`, `dVars`, `Gamma`] + impl_subgoal_tac + validErrorbound_sound + >- ( + fs[DIFF_DEF, SUBSET_DEF] + \\ rpt strip_tac \\ first_x_assum irule + \\ fs[Once freeVars_def, domain_union] + \\ CCONTR_TAC \\ fs[] \\ rveq \\ fs[] + \\ `n IN domain fVars \/ n IN domain dVars` + by (first_x_assum irule \\ fs[])) + \\ fs[] + \\ imp_res_tac meps_0_deterministic \\ rveq + \\ rename1 `FST iv <= vR_e` + \\ rename1 ‘FloverMapTree_find (getRetExp (Let M64 n e f)) A = + SOME (ivR,errR)’ + \\ rename1 `FST iv_e <= vR_e` + \\ rename1 `abs (vR_e - nF) <= err_e` + \\ `abs (vR_e - (fp64_to_real v_e)) <= err_e` + by (first_x_assum irule \\ fs[] + \\ first_x_assum $ irule_at Any) + \\ fs[getRetExp_def] + \\ rename1 `FloverMapTree_find (getRetExp f) A = SOME (iv_f, err_f)` + (* Now construct a new evaluation according to our big-step semantics + using lemma validErrorboundCmd_gives_eval *) + \\ qspecl_then + [ `f`, `A`, `updEnv n vR_e E1`, + `updEnv n (fp64_to_real v_e) E2`, + `outVars`, `fVars`, `insert n () dVars`, `vR`, `FST iv_f`, `SND iv_f`, + `err_f`, `M64`, `Gamma`] + impl_subgoal_tac + validErrorboundCmd_gives_eval + >- ( + fs[] \\ rpt conj_tac + >- ( + irule approxEnvUpdBound + \\ fs[lookup_NONE_domain, toRExpMap_def]) + >- ( + irule ssa_equal_set + \\ qexists_tac `insert n () (union fVars dVars)` + \\ conj_tac \\ TRY (fs[] \\ FAIL_TAC "") + \\ rewrite_tac [domain_union, domain_insert] + \\ rewrite_tac [UNION_DEF, INSERT_DEF] + \\ fs[EXTENSION] + \\ rpt strip_tac + \\ metis_tac[]) + >- ( + fs[DIFF_DEF, domain_insert, SUBSET_DEF] + \\ rpt strip_tac \\ first_x_assum irule + \\ fs[Once freeVars_def] + \\ simp[Once freeVars_def, domain_union])) + \\ fs[optionLift_def] + (* Instantiate IH with newly obtained evaluation, to get the conclusion *) + \\ first_x_assum + (qspecl_then [`updEnv n vR_e E1`, + `updEnv n (fp64_to_real v_e) E2`, + `Gamma`, `vR`, `vF'`, `A`, `fVars`, + `insert n () dVars`, `outVars`] + impl_subgoal_tac) + >- ( + simp[Once validErrorboundCmd_def] + \\ fs [Once FPRangeValidatorCmd_def, Once validTypesCmd_def, + Once validRangesCmd_def] + \\ rpt conj_tac + >- ( + drule approxEnvUpdBound + \\ rpt $ disch_then drule + \\ fs[domain_lookup, lookup_NONE_domain, toRExpMap_def]) + >- ( + irule ssa_equal_set + \\ qexists_tac `insert n () (union fVars dVars)` + \\ conj_tac \\ TRY (fs[] \\ FAIL_TAC "") + \\ rewrite_tac [domain_union, domain_insert] + \\ rewrite_tac [UNION_DEF, INSERT_DEF] + \\ fs[EXTENSION] + \\ rpt strip_tac + \\ metis_tac[]) + >- first_x_assum MATCH_ACCEPT_TAC + >- ( + reverse (sg `m' = M64`) + >- (rveq \\ fs[]) + \\ irule bstep_Gamma_det \\ rpt (find_exists_tac \\ fs[])) + >- ( + fs[DIFF_DEF, domain_insert, SUBSET_DEF] + \\ rpt strip_tac \\ first_x_assum irule + \\ fs[Once freeVars_def] + \\ simp[Once freeVars_def, domain_union]) + >- (rpt strip_tac \\ Cases_on ‘x = n’ \\ gs[] + >- (rveq \\ simp[fp64_to_real_def] + \\ ‘float_is_finite (fp64_to_float v_e)’ + by (gs[float_is_finite_def] + \\‘validFloatValue (float_to_real (fp64_to_float v_e)) M64’ + suffices_by (gs[validValue_gives_float_value]) + \\ irule FPRangeValidator_sound + \\ rpt $ first_x_assum $ irule_at Any + \\ gs[fp64_to_real_def] + \\ fs[Once freeVars_def, domain_union, DIFF_DEF, SUBSET_DEF] + \\ rpt strip_tac \\ first_x_assum irule \\ fs[] + \\ CCONTR_TAC \\ fs[] + \\ rveq \\ fs[] + \\ metis_tac []) + \\ simp[float_to_real_round_robin]) + \\ first_x_assum irule \\ first_x_assum $ irule_at Any) + >- ( + rpt strip_tac \\ simp[updEnv_def] + \\ rveq \\ fs[] + >- ( + irule FPRangeValidator_sound + \\ rpt $ first_x_assum $ irule_at Any \\ conj_tac + \\ fs[Once freeVars_def, domain_union, DIFF_DEF, SUBSET_DEF] + \\ rpt strip_tac \\ first_x_assum irule \\ fs[] + \\ CCONTR_TAC \\ fs[] + \\ rveq \\ fs[] + \\ metis_tac []) + \\ IF_CASES_TAC \\ fs[] + \\ irule FPRangeValidator_sound + \\ rpt $ first_x_assum $ irule_at Any \\ conj_tac + \\ fs[Once freeVars_def, domain_union, DIFF_DEF, SUBSET_DEF]) + \\ fs[] + (** DOUBLE ROUNDING HERE.... **) + \\ ‘updFlEnv n v_e (toFlEnv E2) = toFlEnv (updEnv n (fp64_to_real v_e) E2)’ + by (gs[updFlEnv_def, toFlEnv_def, FUN_EQ_THM] + \\ strip_tac \\ Cases_on ‘x = n’ + \\ + \\ gs[real_to_fp64_def, fp64_to_real_def] + \\ irule let_b \\ fs[toRExpMap_def] \\ find_exists_tac + \\ fs[] \\ irule bstep_eq_env + \\ find_exists_tac \\ fs[] + \\ strip_tac \\ fs[toREnv_def, updEnv_def, updFlEnv_def] + \\ IF_CASES_TAC \\ fs[]) +QED +*) + +val found_tac = TRY (last_x_assum irule \\ find_exists_tac \\ fs[] \\ FAIL_TAC "") + \\ first_x_assum irule \\ find_exists_tac \\ fs[]; + +Theorem IEEE_connection_expr: + !(e:real expr) (A:analysisResult) (P:precond) E1 E2 defVars fVars Gamma. + is64BitEval e /\ + is64BitEnv defVars /\ + noDowncast e /\ + fVars_P_sound fVars E1 P /\ + (domain (usedVars e)) SUBSET (domain fVars) /\ + CertificateChecker e A P defVars = SOME Gamma /\ + approxEnv E1 (toRExpMap Gamma) A fVars LN (toREnv E2) ⇒ + ?iv err vR vF. (* m, currently = M64 *) + FloverMapTree_find e A = SOME (iv, err) /\ + eval_expr E1 (toRTMap (toRExpMap Gamma)) (toREval e) vR REAL /\ + eval_expr_float (toFlExp e) E2 = SOME vF /\ + eval_expr (toREnv E2) (toRExpMap Gamma) e (fp64_to_real vF) M64 /\ + abs (vR - (fp64_to_real vF)) <= err +Proof + simp [CertificateChecker_def] + \\ rpt strip_tac + \\ Cases_on `getValidMap defVars e FloverMapTree_empty` \\ fs[] + \\ rveq \\ imp_res_tac getValidMap_top_correct + \\ `validTypes e Gamma` + by (first_x_assum irule + \\ fs[FloverMapTree_empty_def, FloverMapTree_mem_def, FloverMapTree_find_def]) + \\ `! e m. FloverMapTree_find e Gamma = SOME m ==> m = M64` + by (rpt strip_tac \\ irule getValidMap_preserving + \\ qexistsl_tac [`FloverMapTree_empty`, `defVars`, `e`, `e'`, `Gamma`] + \\ rpt conj_tac \\ rpt strip_tac + \\ fs[FloverMapTree_empty_def, FloverMapTree_find_def , is64BitEnv_def] + \\ first_x_assum irule \\ find_exists_tac \\ fs[]) + \\ drule validIntervalbounds_sound + \\ rpt $ disch_then drule + \\ disch_then (qspecl_then [`fVars`,`E1`, `Gamma`] destruct) + \\ fs[dVars_range_valid_def, fVars_P_sound_def] + \\ drule validErrorbound_sound + \\ rpt $ disch_then drule + \\ imp_res_tac validRanges_single + \\ disch_then (qspecl_then [`vR`, `err`, `FST iv`, `SND iv`] destruct) + \\ fs[] + \\ qspecl_then [`e`, `E1`, `E2`, `Gamma`, `nF`, `A`, `fVars`, `LN`] + destruct + eval_expr_gives_IEEE_reverse + >- ( + rpt conj_tac \\ fs[] + >- ( + `FloverMapTree_find e Gamma = SOME M64` + by (irule typing_expr_64bit \\ fs[is64BitEnv_def] + \\ first_x_assum MATCH_ACCEPT_TAC) + \\ `m = M64` + by (irule validTypes_exec \\ rpt (find_exists_tac \\ fs[])) + \\ rveq \\ fs[]) + \\ fs[is64BitEnv_def] \\ first_x_assum MATCH_ACCEPT_TAC) + \\ rpt $ first_assum $ irule_at Any +QED + +(** Does not work because of let-bindings **) +(* +Theorem IEEE_connection_cmds: + ! (f:word64 cmd) (A:analysisResult) (P:precond) E1 E2 defVars (fVars:num_set) + Gamma. + is64BitBstep (toRCmd f) /\ + is64BitEnv defVars /\ + noDowncastFun (toRCmd f) /\ + fVars_P_sound fVars E1 P /\ + (domain (freeVars (toRCmd f))) SUBSET (domain fVars) /\ + CertificateCheckerCmd (toRCmd f) A P defVars = SOME Gamma /\ + approxEnv E1 (toRExpMap Gamma) A (freeVars (toRCmd f)) LN (toREnv E2) ==> + ?iv err vR vF. (* m, currently = M64 *) + FloverMapTree_find (getRetExp (toRCmd f)) A = SOME (iv, err) /\ + bstep (toREvalCmd (toRCmd f)) E1 (toRTMap (toRExpMap Gamma)) vR REAL /\ + bstep_float f E2 = SOME vF /\ + bstep (toRCmd f) (toREnv E2) (toRExpMap Gamma) + (float_to_real (fp64_to_float vF)) M64 /\ + abs (vR - (float_to_real (fp64_to_float vF))) <= err +Proof + simp [CertificateCheckerCmd_def] + \\ rpt strip_tac + \\ Cases_on `getValidMapCmd defVars (toRCmd f) FloverMapTree_empty` \\ fs[] + \\ rveq \\ IMP_RES_TAC getValidMapCmd_correct + \\ `validTypesCmd (toRCmd f) Gamma` + by (first_x_assum irule + \\ fs[FloverMapTree_empty_def, FloverMapTree_mem_def, FloverMapTree_find_def]) + \\ `! e m. FloverMapTree_find e Gamma = SOME m ==> m = M64` + by (rpt strip_tac \\ irule getValidMapCmd_preserving + \\ qexistsl_tac [`FloverMapTree_empty`, `defVars`, `e`, `toRCmd f`, `Gamma`] + \\ rpt conj_tac \\ rpt strip_tac + \\ fs[FloverMapTree_empty_def, FloverMapTree_find_def , is64BitEnv_def] + \\ first_x_assum irule \\ find_exists_tac \\ fs[]) + \\ `?outVars. ssa (toRCmd f) (freeVars (toRCmd f)) outVars` + by (match_mp_tac validSSA_sound \\ fs[]) + \\ qspecl_then + [`toRCmd f`, `A`, `E1`, `freeVars (toRCmd f)`, `LN`, `outVars`, `P`, `Gamma`] + destruct validIntervalboundsCmd_sound + \\ fs[dVars_range_valid_def, fVars_P_sound_def] + >- (rpt strip_tac \\ first_x_assum irule \\ fs[SUBSET_DEF]) + \\ IMP_RES_TAC validRangesCmd_single + \\ qspecl_then + [`toRCmd f`, `A`, `E1`, `toREnv E2`, `outVars`, `freeVars (toRCmd f)`, `LN`, `vR`, `FST iv_e`, + `SND iv_e`, `err_e`, `M64`, `Gamma`] + destruct validErrorboundCmd_gives_eval + \\ fs[] + \\ rpt (find_exists_tac \\ fs[]) + \\ qspecl_then + [`f`, `E1`, `E2`, `toREnv E2`, `Gamma`, `vR`, `vF`, `A`, `freeVars (toRCmd f)`, `LN`, `outVars`] + destruct + bstep_gives_IEEE + >- (fs[is64BitEnv_def] + \\ conj_tac + >- (`FloverMapTree_find (getRetExp (toRCmd f)) Gamma = SOME M64` + by (irule typing_cmd_64bit + \\ fs[is64BitEnv_def] \\ first_x_assum MATCH_ACCEPT_TAC) + \\ `m = M64` + by (drule validTypesCmd_single + \\ disch_then assume_tac \\ fs[] + \\ fs[] \\ rveq \\ fs[] + \\ first_x_assum irule + \\ qexistsl_tac [`toREnv E2`, `Gamma`, `vF`] \\ fs[]) + \\ rveq \\ fs[]) + \\ first_x_assum MATCH_ACCEPT_TAC) + \\ find_exists_tac \\ fs[] + \\ drule validErrorboundCmd_sound + \\ rpt (disch_then drule) + \\ rename1 `bstep (toRCmd f) (toREnv E2) _ vF2 m2` + \\ disch_then + (qspecl_then + [`outVars`, `vR`, `vF2`, `FST iv_e`, `SND iv_e`, `err_e`, `m2`] destruct) + \\ fs[] +QED +*) + +val _ = export_theory (); diff --git a/icing/flover/Infra/FloverCompLib.sml b/floatingPoint/tools/flover/Infra/FloverCompLib.sml similarity index 100% rename from icing/flover/Infra/FloverCompLib.sml rename to floatingPoint/tools/flover/Infra/FloverCompLib.sml diff --git a/icing/flover/Infra/Holmakefile b/floatingPoint/tools/flover/Infra/Holmakefile similarity index 100% rename from icing/flover/Infra/Holmakefile rename to floatingPoint/tools/flover/Infra/Holmakefile diff --git a/icing/flover/Infra/MachineTypeScript.sml b/floatingPoint/tools/flover/Infra/MachineTypeScript.sml similarity index 100% rename from icing/flover/Infra/MachineTypeScript.sml rename to floatingPoint/tools/flover/Infra/MachineTypeScript.sml diff --git a/floatingPoint/tools/flover/Infra/README.md b/floatingPoint/tools/flover/Infra/README.md new file mode 100644 index 0000000000..5184fc16d7 --- /dev/null +++ b/floatingPoint/tools/flover/Infra/README.md @@ -0,0 +1,16 @@ +Infrastructural lemmas and formalizations for FloVer + +[FloverCompLib.sml](FloverCompLib.sml): +Small changes to computeLib for FloVer + +[MachineTypeScript.sml](MachineTypeScript.sml): +f machine-precision as a datatype for mixed-precision computations + +[RealSimpsScript.sml](RealSimpsScript.sml): +Real-number simplification theorems + +[ResultsLib.sml](ResultsLib.sml): +A monad for results used by FlOVer + +[ResultsScript.sml](ResultsScript.sml): +A simple Result datatype to ease some implementations diff --git a/icing/flover/Infra/RealSimpsScript.sml b/floatingPoint/tools/flover/Infra/RealSimpsScript.sml similarity index 100% rename from icing/flover/Infra/RealSimpsScript.sml rename to floatingPoint/tools/flover/Infra/RealSimpsScript.sml diff --git a/icing/flover/Infra/ResultsLib.sml b/floatingPoint/tools/flover/Infra/ResultsLib.sml similarity index 100% rename from icing/flover/Infra/ResultsLib.sml rename to floatingPoint/tools/flover/Infra/ResultsLib.sml diff --git a/icing/flover/Infra/ResultsScript.sml b/floatingPoint/tools/flover/Infra/ResultsScript.sml similarity index 100% rename from icing/flover/Infra/ResultsScript.sml rename to floatingPoint/tools/flover/Infra/ResultsScript.sml diff --git a/icing/flover/Infra/preambleFloVer.sml b/floatingPoint/tools/flover/Infra/preambleFloVer.sml similarity index 100% rename from icing/flover/Infra/preambleFloVer.sml rename to floatingPoint/tools/flover/Infra/preambleFloVer.sml diff --git a/icing/flover/Infra/readmePrefix b/floatingPoint/tools/flover/Infra/readmePrefix similarity index 100% rename from icing/flover/Infra/readmePrefix rename to floatingPoint/tools/flover/Infra/readmePrefix diff --git a/icing/flover/IntervalArithScript.sml b/floatingPoint/tools/flover/IntervalArithScript.sml similarity index 100% rename from icing/flover/IntervalArithScript.sml rename to floatingPoint/tools/flover/IntervalArithScript.sml diff --git a/icing/flover/IntervalValidationScript.sml b/floatingPoint/tools/flover/IntervalValidationScript.sml similarity index 100% rename from icing/flover/IntervalValidationScript.sml rename to floatingPoint/tools/flover/IntervalValidationScript.sml diff --git a/icing/flover/README.md b/floatingPoint/tools/flover/README.md similarity index 96% rename from icing/flover/README.md rename to floatingPoint/tools/flover/README.md index 75d8a93b43..6d11aaa96c 100644 --- a/icing/flover/README.md +++ b/floatingPoint/tools/flover/README.md @@ -46,6 +46,10 @@ Floating-Point range validator Connect FloVer's idealized machine semantics to 64-bit IEEE-754 floating-point semantics +[IEEE_reverseScript.sml](IEEE_reverseScript.sml): +Connect FloVer's idealized machine semantics to 64-bit +IEEE-754 floating-point semantics + [Infra](Infra): Infrastructural lemmas and formalizations for FloVer diff --git a/icing/flover/RealIntervalInferenceScript.sml b/floatingPoint/tools/flover/RealIntervalInferenceScript.sml similarity index 100% rename from icing/flover/RealIntervalInferenceScript.sml rename to floatingPoint/tools/flover/RealIntervalInferenceScript.sml diff --git a/icing/flover/RealRangeArithScript.sml b/floatingPoint/tools/flover/RealRangeArithScript.sml similarity index 100% rename from icing/flover/RealRangeArithScript.sml rename to floatingPoint/tools/flover/RealRangeArithScript.sml diff --git a/icing/flover/TypeValidatorScript.sml b/floatingPoint/tools/flover/TypeValidatorScript.sml similarity index 100% rename from icing/flover/TypeValidatorScript.sml rename to floatingPoint/tools/flover/TypeValidatorScript.sml diff --git a/icing/flover/divisionRework.sml b/floatingPoint/tools/flover/divisionRework.sml similarity index 100% rename from icing/flover/divisionRework.sml rename to floatingPoint/tools/flover/divisionRework.sml diff --git a/icing/flover/readmePrefix b/floatingPoint/tools/flover/readmePrefix similarity index 100% rename from icing/flover/readmePrefix rename to floatingPoint/tools/flover/readmePrefix diff --git a/icing/flover/semantics/AbbrevsScript.sml b/floatingPoint/tools/flover/semantics/AbbrevsScript.sml similarity index 100% rename from icing/flover/semantics/AbbrevsScript.sml rename to floatingPoint/tools/flover/semantics/AbbrevsScript.sml diff --git a/icing/flover/semantics/CommandsScript.sml b/floatingPoint/tools/flover/semantics/CommandsScript.sml similarity index 100% rename from icing/flover/semantics/CommandsScript.sml rename to floatingPoint/tools/flover/semantics/CommandsScript.sml diff --git a/icing/flover/semantics/ExpressionAbbrevsScript.sml b/floatingPoint/tools/flover/semantics/ExpressionAbbrevsScript.sml similarity index 100% rename from icing/flover/semantics/ExpressionAbbrevsScript.sml rename to floatingPoint/tools/flover/semantics/ExpressionAbbrevsScript.sml diff --git a/icing/flover/semantics/ExpressionSemanticsScript.sml b/floatingPoint/tools/flover/semantics/ExpressionSemanticsScript.sml similarity index 96% rename from icing/flover/semantics/ExpressionSemanticsScript.sml rename to floatingPoint/tools/flover/semantics/ExpressionSemanticsScript.sml index a4dea7133b..8f43dbabb2 100644 --- a/icing/flover/semantics/ExpressionSemanticsScript.sml +++ b/floatingPoint/tools/flover/semantics/ExpressionSemanticsScript.sml @@ -355,4 +355,25 @@ Proof \\ metis_tac[] QED +Theorem swap_gamma_eval_weak: + ∀ e E vR m Gamma1 Gamma2. + (∀ e m. Gamma1 e = SOME m ⇒ Gamma2 e = SOME m) ∧ + eval_expr E Gamma1 e vR m ⇒ + eval_expr E Gamma2 e vR m +Proof + Induct_on `e` \\ fs[eval_expr_cases] \\ rpt strip_tac + >- metis_tac[] + >- metis_tac[] + >- metis_tac[] + >- ( + res_tac + >> rpt $ first_x_assum $ irule_at Any + >> gs[]) + >- ( + res_tac + >> rpt $ first_x_assum $ irule_at Any + >> gs[]) + >- metis_tac[] +QED + val _ = export_theory(); diff --git a/icing/flover/semantics/ExpressionsScript.sml b/floatingPoint/tools/flover/semantics/ExpressionsScript.sml similarity index 81% rename from icing/flover/semantics/ExpressionsScript.sml rename to floatingPoint/tools/flover/semantics/ExpressionsScript.sml index 5e452d6210..bee53e85b7 100644 --- a/icing/flover/semantics/ExpressionsScript.sml +++ b/floatingPoint/tools/flover/semantics/ExpressionsScript.sml @@ -1,7 +1,7 @@ (** Formalization of the base expression language for the flover framework **) -open realTheory realLib sptreeTheory +open realTheory realLib RealArith sptreeTheory intrealTheory; open AbbrevsTheory MachineTypeTheory open preambleFloVer; @@ -98,4 +98,14 @@ Definition usedVars_def: | _ => LN End +Definition ratExp2realExp_def: + ratExp2realExp ((Const m (c,d)):(int#int) expr):real expr = + Const m ((real_of_int c) / (real_of_int d)) ∧ + ratExp2realExp (Var x) = Var x ∧ + ratExp2realExp (Unop u e1) = Unop u (ratExp2realExp e1) ∧ + ratExp2realExp (Binop b e1 e2) = Binop b (ratExp2realExp e1) (ratExp2realExp e2) ∧ + ratExp2realExp (Fma e1 e2 e3) = Fma (ratExp2realExp e1) (ratExp2realExp e2) (ratExp2realExp e3) ∧ + ratExp2realExp (Downcast m e1) = Downcast m (ratExp2realExp e1) +End + val _ = export_theory(); diff --git a/icing/flover/semantics/FloverMapScript.sml b/floatingPoint/tools/flover/semantics/FloverMapScript.sml similarity index 100% rename from icing/flover/semantics/FloverMapScript.sml rename to floatingPoint/tools/flover/semantics/FloverMapScript.sml diff --git a/icing/flover/semantics/Holmakefile b/floatingPoint/tools/flover/semantics/Holmakefile similarity index 100% rename from icing/flover/semantics/Holmakefile rename to floatingPoint/tools/flover/semantics/Holmakefile diff --git a/floatingPoint/tools/flover/semantics/expressionsLib.sml b/floatingPoint/tools/flover/semantics/expressionsLib.sml new file mode 100644 index 0000000000..c35b860d2f --- /dev/null +++ b/floatingPoint/tools/flover/semantics/expressionsLib.sml @@ -0,0 +1,89 @@ +(** + Library to convert between real-valued and rational-valued + FloVer expressions +**) +structure expressionsLib = struct + + open HolKernel Parse Abbrev ExpressionsTheory; + open RealArith realTheory realLib integerTheory intLib bossLib; + + exception FloVerException of string; + + val fvar_tm = “Expressions$Var” + val fconst_tm = “Expressions$Const” + val unop_tm = “Expressions$Unop” + val bop_tm = “Expressions$Binop” + val fma_tm = “Expressions$Fma” + val downcast_tm = “Expressions$Downcast” + + local fun err s = FloVerException ("Not a FloVer " ^ s) in + val dest_fvar = HolKernel.dest_monop fvar_tm $ err "var" + val dest_fconst = HolKernel.dest_binop fconst_tm $ err "const" + val dest_unop = HolKernel.dest_binop unop_tm $ err "unop" + val dest_bop = HolKernel.dest_triop bop_tm $ err "bop" + val dest_fma = HolKernel.dest_triop fma_tm $ err "fma" + val dest_downcast = HolKernel.dest_binop downcast_tm $ err "downcast" + end; + + local fun getArgTy t = type_of t |> dest_type |> snd |> hd in + fun mk_fvar ty n = mk_comb (fvar_tm, n) |> inst [alpha |-> ty] + fun mk_fconst m c = list_mk_comb (inst [alpha |-> type_of c] fconst_tm, [m, c]) + fun mk_unop u e = + list_mk_comb (inst [alpha |-> getArgTy e] unop_tm, [u, e]) + fun mk_bop b e1 e2 = + list_mk_comb (inst [alpha |-> getArgTy e1] bop_tm, [b, e1, e2]) + fun mk_fma e1 e2 e3 = + list_mk_comb (inst [alpha |-> getArgTy e1] fma_tm, [e1, e2, e3]) + fun mk_downcast m e = + list_mk_comb (inst [alpha |-> getArgTy e] downcast_tm, [m, e]) + end; + + val is_fvar = can dest_fvar + val is_fconst = can dest_fconst + val is_unop = can dest_unop + val is_bop = can dest_bop + val is_fma = can dest_fma + val is_downcast = can dest_downcast + + fun realExp2ratExp (t:term) :term = + if type_of t = “:real expr” then + if is_fvar t then let + val var = dest_fvar t in + mk_fvar “:(int # int)” var end + else if is_fconst t then let + val (m,cst) = dest_fconst t + val (n,d) = + if realSyntax.is_div cst then + realSyntax.dest_div cst + else raise FloVerException ("Not a rational number" ^ (term_to_string cst)) + val ni = + if realSyntax.is_real_literal n then + intSyntax.term_of_int $ realSyntax.int_of_term n + else raise FloVerException "Nominator not constant" + val di = + if realSyntax.is_real_literal d then + intSyntax.term_of_int $ realSyntax.int_of_term d + else raise FloVerException "Denominator not constant" + in + mk_fconst m (Parse.Term ‘(^ni, ^di)’) end + else if is_unop t then let + val (uop, e) = dest_unop t in + mk_unop uop (realExp2ratExp e) end + else if is_bop t then let + val (bop, e1, e2) = dest_bop t in + mk_bop bop (realExp2ratExp e1) (realExp2ratExp e2) end + else if is_fma t then let + val (e1, e2, e3) = dest_fma t in + mk_fma (realExp2ratExp e1) (realExp2ratExp e2) (realExp2ratExp e3) end + else if is_downcast t then let + val (m, e) = dest_downcast t in + mk_downcast m (realExp2ratExp e) end + else raise FloVerException ("Unsupported expression constructor in" ^ (term_to_string t)) + else raise FloVerException "Not a real-valued expression"; + + fun realExp2ratExpConv t = + let val t_rat = realExp2ratExp t in + EVAL “^t = ratExp2realExp ^t_rat” |> Rewrite.REWRITE_RULE [boolTheory.EQ_CLAUSES] + end; + +end; diff --git a/icing/flover/semantics/readmePrefix b/floatingPoint/tools/flover/semantics/readmePrefix similarity index 100% rename from icing/flover/semantics/readmePrefix rename to floatingPoint/tools/flover/semantics/readmePrefix diff --git a/icing/flover/sqrtApproxScript.sml b/floatingPoint/tools/flover/sqrtApproxScript.sml similarity index 100% rename from icing/flover/sqrtApproxScript.sml rename to floatingPoint/tools/flover/sqrtApproxScript.sml diff --git a/icing/flover/ssaPrgsScript.sml b/floatingPoint/tools/flover/ssaPrgsScript.sml similarity index 100% rename from icing/flover/ssaPrgsScript.sml rename to floatingPoint/tools/flover/ssaPrgsScript.sml diff --git a/semantics/alt_semantics/bigStepScript.sml b/semantics/alt_semantics/bigStepScript.sml index e257797e8b..173c41df23 100644 --- a/semantics/alt_semantics/bigStepScript.sml +++ b/semantics/alt_semantics/bigStepScript.sml @@ -47,7 +47,8 @@ Inductive opClass: (∀ op. opClass (Real_cmp op) Reals) ∧ (∀ op. opClass (Real_uop op) Reals) ∧ (∀ op. opClass (Real_bop op) Reals) ∧ -(opClass RealFromFP Reals) +(opClass RealFromFP Reals) ∧ +(opClass RealFromIntProd Reals) End Definition compress_if_bool_def: diff --git a/semantics/alt_semantics/itree_semanticsScript.sml b/semantics/alt_semantics/itree_semanticsScript.sml index 5587fd4ec9..4d3cb8cbaa 100644 --- a/semantics/alt_semantics/itree_semanticsScript.sml +++ b/semantics/alt_semantics/itree_semanticsScript.sml @@ -76,6 +76,8 @@ Definition do_app_def: SOME (s, Rval (Real (real_uop uop v1))) | (RealFromFP, [Litv (Word64 fp)]) => SOME (s, Rval (Real (fp64_to_real fp))) + | (RealFromIntProd, [Litv (IntLit i); Litv (IntLit d)]) => + SOME (s, Rval (Real (real_of_int i / real_of_int d))) | (Shift W8 op n, [Litv (Word8 w)]) => SOME (s, Rval (Litv (Word8 (shift8_lookup op w n)))) | (Shift W64 op n, [Litv (Word64 w)]) => diff --git a/semantics/astScript.sml b/semantics/astScript.sml index f59e7db0b9..d9c5ea1947 100644 --- a/semantics/astScript.sml +++ b/semantics/astScript.sml @@ -79,6 +79,8 @@ Datatype: | Real_bop real_bop (* Translation from floating-points to reals for verification *) | RealFromFP + (* Create a real constant from a pair of ints *) + | RealFromIntProd (* Function application *) | Opapp (* Reference operations *) @@ -156,6 +158,7 @@ Definition getOpClass_def[simp]: | Real_bop _ => Reals | Real_uop _ => Reals | RealFromFP => Reals + | RealFromIntProd => Reals | Opapp => FunApp | Eval => EvalOp | _ => Simple diff --git a/semantics/semanticPrimitivesScript.sml b/semantics/semanticPrimitivesScript.sml index 4d2e602911..a3b693424c 100644 --- a/semantics/semanticPrimitivesScript.sml +++ b/semantics/semanticPrimitivesScript.sml @@ -618,9 +618,6 @@ Definition concrete_v_def: | Litv _ => T | Conv v_ vs => concrete_v_list vs | Vectorv vs => concrete_v_list vs - | FP_WordTree fp => T - | FP_BoolTree fp => T - | Real r => T | _ => F) ∧ (concrete_v_list [] ⇔ T) ∧ (concrete_v_list (v::vs) ⇔ concrete_v v ∧ concrete_v_list vs) @@ -873,6 +870,8 @@ Definition do_app_def: SOME ((s,t), Rval (Real (real_uop uop v1))) | (RealFromFP, [Litv (Word64 fp)]) => SOME ((s,t), Rval (Real (fp64_to_real fp))) + | (RealFromIntProd, [Litv (IntLit i); Litv (IntLit d)]) => + SOME ((s,t), Rval (Real (real_of_int i / real_of_int d))) | (Shift W8 op n, [Litv (Word8 w)]) => SOME ((s,t), Rval (Litv (Word8 (shift8_lookup op w n)))) | (Shift W64 op n, [Litv (Word64 w)]) =>